{-# 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