module Language.PureScript.Sugar.TypeDeclarations
( desugarTypeDeclarationsModule
) where
import Prelude
import Control.Monad (unless)
import Control.Monad.Error.Class (MonadError(..))
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Environment
import Language.PureScript.Errors
desugarTypeDeclarationsModule
:: forall m
. MonadError MultipleErrors m
=> Module
-> m Module
desugarTypeDeclarationsModule :: forall (m :: * -> *).
MonadError MultipleErrors m =>
Module -> m Module
desugarTypeDeclarationsModule (Module SourceSpan
modSS [Comment]
coms ModuleName
name [Declaration]
ds Maybe [DeclarationRef]
exps) =
forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
name)) forall a b. (a -> b) -> a -> b
$ do
[Declaration] -> m ()
checkKindDeclarations [Declaration]
ds
Maybe Declaration -> [Declaration] -> m ()
checkRoleDeclarations forall a. Maybe a
Nothing [Declaration]
ds
SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
modSS [Comment]
coms ModuleName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exps
where
desugarTypeDeclarations :: [Declaration] -> m [Declaration]
desugarTypeDeclarations :: [Declaration] -> m [Declaration]
desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData SourceAnn
sa Ident
name' SourceType
ty) : Declaration
d : [Declaration]
rest) = do
(Ident
_, NameKind
nameKind, Expr
val) <- Declaration -> m (Ident, NameKind, Expr)
fromValueDeclaration Declaration
d
[Declaration] -> m [Declaration]
desugarTypeDeclarations (SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name' NameKind
nameKind [] [Expr -> GuardedExpr
MkUnguarded (Bool -> Expr -> SourceType -> Expr
TypedValue Bool
True Expr
val SourceType
ty)] forall a. a -> [a] -> [a]
: [Declaration]
rest)
where
fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
fromValueDeclaration (ValueDecl SourceAnn
_ Ident
name'' NameKind
nameKind [] [MkUnguarded Expr
val])
| Ident
name' forall a. Eq a => a -> a -> Bool
== Ident
name'' = forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
name'', NameKind
nameKind, Expr
val)
fromValueDeclaration Declaration
d' =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (Declaration -> SourceSpan
declSourceSpan Declaration
d') forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
OrphanTypeDeclaration Ident
name'
desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (SourceSpan
ss, [Comment]
_) Ident
name' SourceType
_)] =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
OrphanTypeDeclaration Ident
name'
desugarTypeDeclarations (ValueDecl SourceAnn
sa Ident
name' NameKind
nameKind [Binder]
bs [GuardedExpr]
val : [Declaration]
rest) = do
let (Declaration -> m Declaration
_, Expr -> m Expr
f, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
Binder -> m Binder)
everywhereOnValuesTopDownM forall (m :: * -> *) a. Monad m => a -> m a
return Expr -> m Expr
go forall (m :: * -> *) a. Monad m => a -> m a
return
f' :: [GuardedExpr] -> m [GuardedExpr]
f' = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(GuardedExpr [Guard]
g Expr
e) -> [Guard] -> Expr -> GuardedExpr
GuardedExpr [Guard]
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m Expr
f Expr
e)
(:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name' NameKind
nameKind [Binder]
bs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedExpr] -> m [GuardedExpr]
f' [GuardedExpr]
val)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
rest
where
go :: Expr -> m Expr
go (Let WhereProvenance
w [Declaration]
ds' Expr
val') = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
ds' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
val'
go Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other
desugarTypeDeclarations (TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
ch Integer
idx Either Text Ident
nm [SourceConstraint]
deps Qualified (ProperName 'ClassName)
cls [SourceType]
args (ExplicitInstance [Declaration]
ds') : [Declaration]
rest) =
(:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceAnn
-> SourceAnn
-> ChainId
-> Integer
-> Either Text Ident
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> TypeInstanceBody
-> Declaration
TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
ch Integer
idx Either Text Ident
nm [SourceConstraint]
deps Qualified (ProperName 'ClassName)
cls [SourceType]
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration] -> TypeInstanceBody
ExplicitInstance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
ds')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
rest
desugarTypeDeclarations (Declaration
d:[Declaration]
rest) = (:) Declaration
d forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
desugarTypeDeclarations [Declaration]
rest
desugarTypeDeclarations [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
checkKindDeclarations :: [Declaration] -> m ()
checkKindDeclarations :: [Declaration] -> m ()
checkKindDeclarations (KindDeclaration SourceAnn
sa KindSignatureFor
kindFor ProperName 'TypeName
name' SourceType
_ : Declaration
d : [Declaration]
rest) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Declaration -> Bool
matchesDeclaration Declaration
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
sa) forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
OrphanKindDeclaration ProperName 'TypeName
name'
[Declaration] -> m ()
checkKindDeclarations [Declaration]
rest
where
matchesDeclaration :: Declaration -> Bool
matchesDeclaration :: Declaration -> Bool
matchesDeclaration (DataDeclaration SourceAnn
_ DataDeclType
Data ProperName 'TypeName
name'' [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) = KindSignatureFor
kindFor forall a. Eq a => a -> a -> Bool
== KindSignatureFor
DataSig Bool -> Bool -> Bool
&& ProperName 'TypeName
name' forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name''
matchesDeclaration (DataDeclaration SourceAnn
_ DataDeclType
Newtype ProperName 'TypeName
name'' [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) = KindSignatureFor
kindFor forall a. Eq a => a -> a -> Bool
== KindSignatureFor
NewtypeSig Bool -> Bool -> Bool
&& ProperName 'TypeName
name' forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name''
matchesDeclaration (TypeSynonymDeclaration SourceAnn
_ ProperName 'TypeName
name'' [(Text, Maybe SourceType)]
_ SourceType
_) = KindSignatureFor
kindFor forall a. Eq a => a -> a -> Bool
== KindSignatureFor
TypeSynonymSig Bool -> Bool -> Bool
&& ProperName 'TypeName
name' forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name''
matchesDeclaration (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
name'' [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
_) = KindSignatureFor
kindFor forall a. Eq a => a -> a -> Bool
== KindSignatureFor
ClassSig Bool -> Bool -> Bool
&& ProperName 'TypeName
name' forall a. Eq a => a -> a -> Bool
== forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name''
matchesDeclaration Declaration
_ = Bool
False
checkKindDeclarations (KindDeclaration SourceAnn
sa KindSignatureFor
_ ProperName 'TypeName
name' SourceType
_ : [Declaration]
_) = do
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
sa) forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
OrphanKindDeclaration ProperName 'TypeName
name'
checkKindDeclarations (Declaration
_ : [Declaration]
rest) = [Declaration] -> m ()
checkKindDeclarations [Declaration]
rest
checkKindDeclarations [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m ()
checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m ()
checkRoleDeclarations Maybe Declaration
Nothing (RoleDeclaration RoleDeclarationData{[Role]
SourceAnn
ProperName 'TypeName
rdeclRoles :: RoleDeclarationData -> [Role]
rdeclIdent :: RoleDeclarationData -> ProperName 'TypeName
rdeclSourceAnn :: RoleDeclarationData -> SourceAnn
rdeclRoles :: [Role]
rdeclIdent :: ProperName 'TypeName
rdeclSourceAnn :: SourceAnn
..} : [Declaration]
_) =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
rdeclSourceAnn) forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
OrphanRoleDeclaration ProperName 'TypeName
rdeclIdent
checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData SourceAnn
_ ProperName 'TypeName
name' [Role]
_))) ((RoleDeclaration RoleDeclarationData{[Role]
SourceAnn
ProperName 'TypeName
rdeclRoles :: [Role]
rdeclIdent :: ProperName 'TypeName
rdeclSourceAnn :: SourceAnn
rdeclRoles :: RoleDeclarationData -> [Role]
rdeclIdent :: RoleDeclarationData -> ProperName 'TypeName
rdeclSourceAnn :: RoleDeclarationData -> SourceAnn
..}) : [Declaration]
_) | ProperName 'TypeName
name' forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
rdeclIdent =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
rdeclSourceAnn) forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
DuplicateRoleDeclaration ProperName 'TypeName
rdeclIdent
checkRoleDeclarations (Just Declaration
d) (rd :: Declaration
rd@(RoleDeclaration RoleDeclarationData{[Role]
SourceAnn
ProperName 'TypeName
rdeclRoles :: [Role]
rdeclIdent :: ProperName 'TypeName
rdeclSourceAnn :: SourceAnn
rdeclRoles :: RoleDeclarationData -> [Role]
rdeclIdent :: RoleDeclarationData -> ProperName 'TypeName
rdeclSourceAnn :: RoleDeclarationData -> SourceAnn
..}) : [Declaration]
rest) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Declaration -> Bool
matchesDeclaration Declaration
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
rdeclSourceAnn) forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
OrphanRoleDeclaration ProperName 'TypeName
rdeclIdent
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Declaration -> Bool
isSupported Declaration
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a b. (a, b) -> a
fst SourceAnn
rdeclSourceAnn) forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage
UnsupportedRoleDeclaration
Maybe Declaration -> [Declaration] -> m ()
checkRoleDeclarations (forall a. a -> Maybe a
Just Declaration
rd) [Declaration]
rest
where
isSupported :: Declaration -> Bool
isSupported :: Declaration -> Bool
isSupported DataDeclaration{} = Bool
True
isSupported ExternDataDeclaration{} = Bool
True
isSupported Declaration
_ = Bool
False
matchesDeclaration :: Declaration -> Bool
matchesDeclaration :: Declaration -> Bool
matchesDeclaration (DataDeclaration SourceAnn
_ DataDeclType
_ ProperName 'TypeName
name' [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) = ProperName 'TypeName
rdeclIdent forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name'
matchesDeclaration (ExternDataDeclaration SourceAnn
_ ProperName 'TypeName
name' SourceType
_) = ProperName 'TypeName
rdeclIdent forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name'
matchesDeclaration (TypeSynonymDeclaration SourceAnn
_ ProperName 'TypeName
name' [(Text, Maybe SourceType)]
_ SourceType
_) = ProperName 'TypeName
rdeclIdent forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
name'
matchesDeclaration (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
name' [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
_) = ProperName 'TypeName
rdeclIdent forall a. Eq a => a -> a -> Bool
== forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name'
matchesDeclaration Declaration
_ = Bool
False
checkRoleDeclarations Maybe Declaration
_ (Declaration
d : [Declaration]
rest) = Maybe Declaration -> [Declaration] -> m ()
checkRoleDeclarations (forall a. a -> Maybe a
Just Declaration
d) [Declaration]
rest
checkRoleDeclarations Maybe Declaration
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()