-- |
-- 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 (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)

-- |
-- 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 ()