-- |
-- This module implements the desugaring pass which replaces top-level type
-- declarations with type annotations on the corresponding expression.
--
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

-- |
-- Replace all top level type declarations in a module with type annotations
--
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 ()