{- |
    Module      :  $Header$
    Description :  Checks deriving clauses
    Copyright   :  (c)        2016 Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   Before entering derived instances into the instance environment, the
   compiler has to ensure that it is not asked for other instances than
   those of supported type classes.
-}
module Checks.DeriveCheck (deriveCheck) where

import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Base.SpanInfo (HasSpanInfo)
import Curry.Syntax

import Base.Messages (Message, spanInfoMessage)

import Env.TypeConstructor

deriveCheck :: TCEnv -> Module a -> [Message]
deriveCheck :: TCEnv -> Module a -> [Message]
deriveCheck tcEnv :: TCEnv
tcEnv (Module _ _ _ m :: ModuleIdent
m _ _ ds :: [Decl a]
ds) = (Decl a -> [Message]) -> [Decl a] -> [Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleIdent -> TCEnv -> Decl a -> [Message]
forall a. ModuleIdent -> TCEnv -> Decl a -> [Message]
checkDecl ModuleIdent
m TCEnv
tcEnv) [Decl a]
ds

-- No instances can be derived for abstract data types as well as for
-- existential data types.

checkDecl :: ModuleIdent -> TCEnv -> Decl a -> [Message]
checkDecl :: ModuleIdent -> TCEnv -> Decl a -> [Message]
checkDecl m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (DataDecl   _ tc :: Ident
tc _ cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss)
  | [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QualIdent]
clss                       = []
  | [ConstrDecl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstrDecl]
cs                         = [Ident -> Message
forall a. HasSpanInfo a => a -> Message
errNoAbstractDerive Ident
tc]
  | Bool
otherwise                       = (QualIdent -> [Message]) -> [QualIdent] -> [Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleIdent -> TCEnv -> [ConstrDecl] -> QualIdent -> [Message]
checkDerivable ModuleIdent
m TCEnv
tcEnv [ConstrDecl]
cs) [QualIdent]
clss
checkDecl m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (NewtypeDecl _ _ _ nc :: NewConstrDecl
nc clss :: [QualIdent]
clss) =
  (QualIdent -> [Message]) -> [QualIdent] -> [Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleIdent -> TCEnv -> [ConstrDecl] -> QualIdent -> [Message]
checkDerivable ModuleIdent
m TCEnv
tcEnv [NewConstrDecl -> ConstrDecl
toConstrDecl NewConstrDecl
nc]) [QualIdent]
clss
checkDecl _ _     _                           = []

checkDerivable :: ModuleIdent -> TCEnv -> [ConstrDecl] -> QualIdent -> [Message]
checkDerivable :: ModuleIdent -> TCEnv -> [ConstrDecl] -> QualIdent -> [Message]
checkDerivable m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv cs :: [ConstrDecl]
cs cls :: QualIdent
cls
  | QualIdent
ocls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qEnumId Bool -> Bool -> Bool
&& Bool -> Bool
not ([ConstrDecl] -> Bool
isEnum [ConstrDecl]
cs)       = [QualIdent -> Message
errNotEnum QualIdent
cls]
  | QualIdent
ocls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qBoundedId Bool -> Bool -> Bool
&& Bool -> Bool
not ([ConstrDecl] -> Bool
isBounded [ConstrDecl]
cs) = [QualIdent -> Message
errNotBounded QualIdent
cls]
  | QualIdent
ocls QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [QualIdent]
derivableClasses          = [QualIdent -> Message
errNotDerivable QualIdent
cls]
  | QualIdent
ocls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qDataId                          = [QualIdent -> Message
errNoDataDerive QualIdent
cls]
  | Bool
otherwise                                = []
  where ocls :: QualIdent
ocls = ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m QualIdent
cls TCEnv
tcEnv

derivableClasses :: [QualIdent]
derivableClasses :: [QualIdent]
derivableClasses = [QualIdent
qEqId, QualIdent
qOrdId, QualIdent
qEnumId, QualIdent
qBoundedId, QualIdent
qReadId, QualIdent
qShowId, QualIdent
qDataId]

-- Instances of 'Enum' can be derived only for enumeration types, i.e., types
-- where all data constructors are constants.

isEnum :: [ConstrDecl] -> Bool
isEnum :: [ConstrDecl] -> Bool
isEnum = (ConstrDecl -> Bool) -> [ConstrDecl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool) -> (ConstrDecl -> Int) -> ConstrDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstrDecl -> Int
constrArity)

-- Instances of 'Bounded' can be derived only for enumerations and for single
-- constructor types.

isBounded :: [ConstrDecl] -> Bool
isBounded :: [ConstrDecl] -> Bool
isBounded cs :: [ConstrDecl]
cs = [ConstrDecl] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstrDecl]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| [ConstrDecl] -> Bool
isEnum [ConstrDecl]
cs

-- ---------------------------------------------------------------------------
-- Auxiliary functions
-- ---------------------------------------------------------------------------

toConstrDecl :: NewConstrDecl -> ConstrDecl
toConstrDecl :: NewConstrDecl -> ConstrDecl
toConstrDecl (NewConstrDecl p :: SpanInfo
p c :: Ident
c      ty :: TypeExpr
ty) = SpanInfo -> Ident -> [TypeExpr] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
c [TypeExpr
ty]
toConstrDecl (NewRecordDecl p :: SpanInfo
p c :: Ident
c (l :: Ident
l, ty :: TypeExpr
ty)) =
  SpanInfo -> Ident -> [FieldDecl] -> ConstrDecl
RecordDecl SpanInfo
p Ident
c [SpanInfo -> [Ident] -> TypeExpr -> FieldDecl
FieldDecl SpanInfo
p [Ident
l] TypeExpr
ty]

constrArity :: ConstrDecl -> Int
constrArity :: ConstrDecl -> Int
constrArity (ConstrDecl  _ _ tys :: [TypeExpr]
tys) = [TypeExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeExpr]
tys
constrArity (ConOpDecl   _ _ _ _) = 2
constrArity c :: ConstrDecl
c@(RecordDecl  _ _ _) = [Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Ident] -> Int) -> [Ident] -> Int
forall a b. (a -> b) -> a -> b
$ ConstrDecl -> [Ident]
recordLabels ConstrDecl
c

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errNoAbstractDerive :: HasSpanInfo a => a -> Message
errNoAbstractDerive :: a -> Message
errNoAbstractDerive s :: a
s = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
s (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Instances can only be derived for data types with" Doc -> Doc -> Doc
<+>
  String -> Doc
text "at least one constructor"

errNotDerivable :: QualIdent -> Message
errNotDerivable :: QualIdent -> Message
errNotDerivable cls :: QualIdent
cls = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
cls (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Instances of type class", QualIdent -> String
escQualName QualIdent
cls, "cannot be derived"]

errNoDataDerive :: QualIdent -> Message
errNoDataDerive :: QualIdent -> Message
errNoDataDerive qcls :: QualIdent
qcls = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
qcls (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Instances of type class"
  , QualIdent -> String
escQualName QualIdent
qcls
  , "are automatically derived if possible"
  ]

errNotEnum :: QualIdent -> Message
errNotEnum :: QualIdent -> Message
errNotEnum qcls :: QualIdent
qcls = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
qcls (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Instances of type class"
  , QualIdent -> String
escQualName QualIdent
qcls
  , "can be derived only for enumeration types"
  ]

errNotBounded :: QualIdent -> Message
errNotBounded :: QualIdent -> Message
errNotBounded qcls :: QualIdent
qcls = QualIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualIdent
qcls (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Instances of type class"
  , QualIdent -> String
escQualName QualIdent
qcls
  , "can be derived only for enumeration and single constructor types"
  ]