content: -- |
  -- 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 (Module modSS coms name ds exps) =
    rethrow (addHint (ErrorInModule name)) $ do
      checkKindDeclarations ds
      checkRoleDeclarations Nothing ds
      Module modSS coms name <$> desugarTypeDeclarations ds <*> pure exps
    where
  
    desugarTypeDeclarations :: [Declaration] -> m [Declaration]
    desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do
      (_, nameKind, val) <- fromValueDeclaration d
      desugarTypeDeclarations (ValueDecl sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest)
      where
      fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
      fromValueDeclaration (ValueDecl _ name'' nameKind [] [MkUnguarded val])
        | name' == name'' = return (name'', nameKind, val)
      fromValueDeclaration d' =
        throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name'
    desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] =
      throwError . errorMessage' ss $ OrphanTypeDeclaration name'
    desugarTypeDeclarations (ValueDecl sa name' nameKind bs val : rest) = do
      let (_, f, _) = everywhereOnValuesTopDownM return go return
          f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e)
      (:) <$> (ValueDecl sa name' nameKind bs <$> f' val)
          <*> desugarTypeDeclarations rest
      where
      go (Let w ds' val') = Let w <$> desugarTypeDeclarations ds' <*> pure val'
      go other = return other
    desugarTypeDeclarations (TypeInstanceDeclaration sa na ch idx nm deps cls args (ExplicitInstance ds') : rest) =
      (:) <$> (TypeInstanceDeclaration sa na ch idx nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds')
          <*> desugarTypeDeclarations rest
    desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest
    desugarTypeDeclarations [] = return []
  
    checkKindDeclarations :: [Declaration] -> m ()
    checkKindDeclarations (KindDeclaration sa kindFor name' _ : d : rest) = do
      unless (matchesDeclaration d) . throwError . errorMessage' (fst sa) $ OrphanKindDeclaration name'
      checkKindDeclarations rest
      where
      matchesDeclaration :: Declaration -> Bool
      matchesDeclaration (DataDeclaration _ Data name'' _ _) = kindFor == DataSig && name' == name''
      matchesDeclaration (DataDeclaration _ Newtype name'' _ _) = kindFor == NewtypeSig && name' == name''
      matchesDeclaration (TypeSynonymDeclaration _ name'' _ _) = kindFor == TypeSynonymSig && name' == name''
      matchesDeclaration (TypeClassDeclaration _ name'' _ _ _ _) = kindFor == ClassSig && name' == coerceProperName name''
      matchesDeclaration _ = False
    checkKindDeclarations (KindDeclaration sa _ name' _ : _) = do
      throwError . errorMessage' (fst sa) $ OrphanKindDeclaration name'
    checkKindDeclarations (_ : rest) = checkKindDeclarations rest
    checkKindDeclarations [] = return ()
  
    checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m ()
    checkRoleDeclarations Nothing (RoleDeclaration RoleDeclarationData{..} : _) =
      throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent
    checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration RoleDeclarationData{..}) : _) | name' == rdeclIdent =
      throwError . errorMessage' (fst rdeclSourceAnn) $ DuplicateRoleDeclaration rdeclIdent
    checkRoleDeclarations (Just d) (rd@(RoleDeclaration RoleDeclarationData{..}) : rest) = do
      unless (matchesDeclaration d) . throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent
      unless (isSupported d) . throwError . errorMessage' (fst rdeclSourceAnn) $ UnsupportedRoleDeclaration
      checkRoleDeclarations (Just rd) rest
      where
      isSupported :: Declaration -> Bool
      isSupported DataDeclaration{} = True
      isSupported ExternDataDeclaration{} = True
      isSupported _ = False
      matchesDeclaration :: Declaration -> Bool
      matchesDeclaration (DataDeclaration _ _ name' _ _) = rdeclIdent == name'
      matchesDeclaration (ExternDataDeclaration _ name' _) = rdeclIdent == name'
      matchesDeclaration (TypeSynonymDeclaration _ name' _ _) = rdeclIdent == name'
      matchesDeclaration (TypeClassDeclaration _ name' _ _ _ _) = rdeclIdent == coerceProperName name'
      matchesDeclaration _ = False
    checkRoleDeclarations _ (d : rest) = checkRoleDeclarations (Just d) rest
    checkRoleDeclarations _ [] = return ()
  