module Language.PureScript.Sugar.TypeDeclarations
( desugarTypeDeclarationsModule
) where
import Prelude
import Control.Monad (unless)
import Control.Monad.Error.Class (MonadError(..))
import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM)
import Language.PureScript.Names (Ident, coerceProperName)
import Language.PureScript.Environment (DataDeclType(..), NameKind)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow)
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 ()