120 lines
3.6 KiB
Haskell
120 lines
3.6 KiB
Haskell
{-# LANGUAGE TupleSections, LambdaCase, OverloadedStrings #-}
|
|
module PostProcess where
|
|
|
|
import Control.Monad.State hiding (guard)
|
|
import Control.Monad.Except hiding (guard)
|
|
|
|
import Data.Map (Map)
|
|
import Data.Set (Set)
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
|
|
import qualified Hm.Abs as H
|
|
import Type
|
|
import Misc
|
|
import TC.Helpers
|
|
import TC
|
|
|
|
import Prelude hiding (map)
|
|
|
|
-- Type env for parsing type signatures
|
|
type Process = StateT (Set Id) Infer
|
|
|
|
insertType :: Id -> Process ()
|
|
insertType i = get >>= put . S.insert i
|
|
|
|
runProcess :: Process a -> Set Id -> Infer a
|
|
runProcess = (fst <$>) .: runStateT
|
|
|
|
postprocess :: [H.Def] -> Process [TL]
|
|
postprocess defs = addDef <~> defs >> defToTL <~> defs
|
|
|
|
-- just adds types for processing type signatures
|
|
addDef :: H.Def -> Process ()
|
|
addDef = \case
|
|
H.TypeDef _ t _ -> insertType =<< fst <$> typeSigToIdParams t
|
|
H.VarDef _ i t _ -> pure ()
|
|
|
|
-- add type before typesig to id params
|
|
defToTL :: H.Def -> Process TL
|
|
defToTL (H.VarDef p i t e) = VarDef p i <$> typeSigToPolyT t <*> expToExp e
|
|
defToTL (H.TypeDef p t ds) = do
|
|
(i,_) <- typeSigToIdParams t
|
|
|
|
let (Id s) = i
|
|
|
|
monoT <- declTo2pl <~> ds
|
|
let monoTs = map snd monoT
|
|
let env = M.fromList (map (\(i,m) -> (i, Mono m)) monoT)
|
|
|
|
-- check that all constructors construct correct type
|
|
mapM_ (guard (throwError (InvalidConstructor)) . constructs i) monoTs
|
|
|
|
-- check that there are no unbound variables
|
|
guard (throwError (Unimplemented "Type parameters")) (free env == S.empty)
|
|
|
|
-- dissallow contradictory types
|
|
mapM_ (guard (throwError (PositivityCheck i)) . positivityCheck i) monoTs
|
|
|
|
-- add recursor to env
|
|
tv <- lift fresh
|
|
|
|
let replace = \case {
|
|
TArr l@TArr{} r -> TArr l (replace r) ;
|
|
TArr l r -> TArr (replace l) (replace r) ;
|
|
TCon i' -> if i' == i then tv else TCon i' ;
|
|
TVar i' -> TVar i' ;
|
|
}
|
|
|
|
recType <- lift . generalize . foldr TArr (TCon i `TArr` tv) . map replace $ monoTs
|
|
|
|
let env' = M.insert (Id ("rec[" <> s <> "]")) recType env
|
|
|
|
pure (TypeDef p i [] env')
|
|
|
|
positivityCheck :: Id -> MonoT -> Bool
|
|
positivityCheck i = \case
|
|
TArr l@TArr{} r -> not (parameterIn i l)
|
|
TArr l r -> positivityCheck i l && positivityCheck i r
|
|
_ -> True
|
|
|
|
parameterIn :: Id -> MonoT -> Bool
|
|
parameterIn i = \case
|
|
TArr (TCon i') r -> i' == i || parameterIn i r
|
|
TArr l r -> parameterIn i l || parameterIn i r
|
|
_ -> False
|
|
|
|
|
|
typeSigToIdParams :: H.TypeSig -> Process (Id, [Id])
|
|
typeSigToIdParams = \case
|
|
H.TypeFun{} -> throwError InvalidTypeDecl
|
|
H.TypeApp{} -> throwError (Unimplemented "Type parameters")
|
|
H.TypeVar _ i -> pure (i, [])
|
|
|
|
typeSigToPolyT :: H.TypeSig -> Process PolyT
|
|
typeSigToPolyT t = typeSigToMonoT t >>= lift . generalize
|
|
|
|
typeSigToMonoT :: H.TypeSig -> Process MonoT
|
|
typeSigToMonoT = \case
|
|
H.TypeFun _ t1 t2 -> typeSigToMonoT t1 >>= (<$> typeSigToMonoT t2) . TArr
|
|
H.TypeApp {} -> throwError (Unimplemented "Type parameters")
|
|
H.TypeVar _ i -> get >>= \s -> pure $
|
|
if S.member i s
|
|
then TCon i
|
|
else TVar i
|
|
|
|
expToExp :: H.Exp -> Process Exp
|
|
expToExp = \case
|
|
H.ExpLet p as e -> Let p <$> assignTo2pl <~> as <*> expToExp e
|
|
H.ExpAbs p is e -> Abs p is <$> expToExp e
|
|
H.ExpApp p e es -> App p <$> expToExp e <*> expToExp <~> es
|
|
H.ExpVar p i -> pure (Var p i)
|
|
|
|
declTo2pl :: H.Decl -> Process (Id, MonoT)
|
|
declTo2pl (H.Decl _ i t) = (i,) <$> typeSigToMonoT t
|
|
|
|
assignTo2pl :: H.Assign -> Process (Id, Exp)
|
|
assignTo2pl (H.Assign _ i e) = (i,) <$> expToExp e
|