almost done
This commit is contained in:
crumbtoo
@@ -1,15 +1,204 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Core.SystemF
|
||||
( lintCoreProgR
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import GHC.Generics (Generic, Generically(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Function (on)
|
||||
import Data.Traversable
|
||||
import Data.Foldable
|
||||
import Data.List.Extra
|
||||
import Control.Monad.Utils
|
||||
import Control.Monad
|
||||
|
||||
import Control.Comonad
|
||||
import Control.Comonad.Cofree
|
||||
import Data.Fix
|
||||
import Data.Functor
|
||||
|
||||
import Control.Lens hiding ((:<))
|
||||
import Control.Lens.Unsound
|
||||
|
||||
import Compiler.RLPC
|
||||
import Core
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Gamma = Gamma
|
||||
{ _gammaVars :: HashMap Name Type
|
||||
, _gammaTyVars :: HashMap Name Kind
|
||||
, _gammaTyCons :: HashMap Name Kind
|
||||
}
|
||||
deriving (Generic)
|
||||
deriving (Semigroup, Monoid)
|
||||
via (Generically Gamma)
|
||||
|
||||
makeLenses ''Gamma
|
||||
|
||||
lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name)
|
||||
lintCoreProgR = undefined
|
||||
|
||||
lint :: Program Var -> Program Name
|
||||
lint = undefined
|
||||
|
||||
type ET = Cofree (ExprF Var) Type
|
||||
|
||||
type SysF = Either TypeError
|
||||
|
||||
data TypeError = TypeErrorUndefinedVariable Name
|
||||
| TypeErrorKindMismatch Kind Kind
|
||||
| TypeErrorCouldNotMatch Type Type
|
||||
deriving Show
|
||||
|
||||
lintE :: Gamma -> Expr Var -> SysF ET
|
||||
lintE g = \case
|
||||
Var n -> lookupVar g n <&> (:< VarF n)
|
||||
Lit (IntL n) -> pure $ TyInt :< LitF (IntL n)
|
||||
|
||||
Type t -> kindOf g t <&> (:< TypeF t)
|
||||
|
||||
App f x
|
||||
-- type application
|
||||
| Right (TyForall (a :^ k) m :< f') <- lintE g f
|
||||
, Right (k' :< TypeF t) <- lintE g x
|
||||
, k == k'
|
||||
-> pure $ subst a t m :< f'
|
||||
|
||||
-- value application
|
||||
| Right fw@((s :-> t) :< _) <- lintE g f
|
||||
, Right xw@(s' :< _) <- lintE g x
|
||||
, s == s'
|
||||
-> pure $ t :< AppF fw xw
|
||||
|
||||
Lam bs e -> do
|
||||
e'@(t :< _) <- lintE g' e
|
||||
pure $ foldr arrowify t bs :< LamF bs e'
|
||||
where
|
||||
g' = foldMap suppl bs <> g
|
||||
|
||||
suppl (MkVar n t)
|
||||
| isKind t = mempty & gammaTyVars %~ H.insert n t
|
||||
| otherwise = mempty & gammaVars %~ H.insert n t
|
||||
|
||||
arrowify (MkVar n s) s'
|
||||
| isKind s = TyForall (n :^ s) s'
|
||||
| otherwise = s :-> s'
|
||||
|
||||
Let Rec bs e -> do
|
||||
e'@(t :< _) <- lintE g' e
|
||||
bs' <- (uncurry checkBind . (_2 %~ wrapFix)) `traverse` binds
|
||||
pure $ t :< LetF Rec bs' e'
|
||||
where
|
||||
binds = bs ^.. each . _BindingF
|
||||
vs = binds ^.. each . _1 . _MkVar
|
||||
g' = supplementVars vs g
|
||||
checkBind v@(MkVar n t) e = case lintE g' e of
|
||||
Right (t' :< e') | t == t' -> Right (BindingF v e')
|
||||
| otherwise -> Left (TypeErrorCouldNotMatch t t')
|
||||
Left e -> Left e
|
||||
Let NonRec bs e -> do
|
||||
(g',bs') <- mapAccumLM checkBind g bs
|
||||
e'@(t :< _) <- lintE g' e
|
||||
pure $ t :< LetF NonRec bs' e'
|
||||
where
|
||||
checkBind :: Gamma -> BindingF Var (Expr Var)
|
||||
-> SysF (Gamma, BindingF Var ET)
|
||||
checkBind g (BindingF v@(n :^ t) e) = case lintE g (wrapFix e) of
|
||||
Right (t' :< e')
|
||||
| t == t' -> Right (supplementVar n t g, BindingF v e')
|
||||
| otherwise -> Left (TypeErrorCouldNotMatch t t')
|
||||
Left e -> Left e
|
||||
|
||||
Case e as -> do
|
||||
(ts,as') <- unzip <$> checkAlt `traverse` as
|
||||
unless (allSame ts) $
|
||||
Left (error "unifica oh my god fix this later")
|
||||
e' <- lintE g e
|
||||
pure $ head ts :< CaseF e' as'
|
||||
where
|
||||
checkAlt :: Alter Var -> SysF (Type, AlterF Var ET)
|
||||
checkAlt (AlterF (AltData con) bs e) = do
|
||||
ct <- lookupVar g con
|
||||
zipWithM_ fzip bs (ct ^.. arrowStops)
|
||||
(t :< e') <- lintE (supplementVars (varsToPairs bs) g) (wrapFix e)
|
||||
pure (t, AlterF (AltData con) bs e')
|
||||
where
|
||||
fzip (MkVar _ t) t'
|
||||
| t == t' = Right ()
|
||||
| otherwise = Left (TypeErrorCouldNotMatch t t')
|
||||
|
||||
unforall :: Type -> Type
|
||||
unforall (TyForall _ m) = m
|
||||
unforall m = m
|
||||
|
||||
varsToPairs :: [Var] -> [(Name, Type)]
|
||||
varsToPairs = toListOf (each . _MkVar)
|
||||
|
||||
checkAgainst :: Gamma -> Var -> Expr Var -> SysF ET
|
||||
checkAgainst g v@(MkVar n t) e = case lintE g e of
|
||||
Right e'@(t' :< _) | t == t' -> Right e'
|
||||
| otherwise -> Left (TypeErrorCouldNotMatch t t')
|
||||
Left a -> Left a
|
||||
|
||||
supplementVars :: [(Name, Type)] -> Gamma -> Gamma
|
||||
supplementVars vs = gammaVars <>~ H.fromList vs
|
||||
|
||||
supplementVar :: Name -> Type -> Gamma -> Gamma
|
||||
supplementVar n t = gammaVars %~ H.insert n t
|
||||
|
||||
supplementTyVar :: Name -> Kind -> Gamma -> Gamma
|
||||
supplementTyVar n t = gammaTyVars %~ H.insert n t
|
||||
|
||||
subst :: Name -> Type -> Type -> Type
|
||||
subst k v (TyVar n) | k == n = v
|
||||
subst k v (TyForall (MkVar n k') t)
|
||||
| k /= n = TyForall (MkVar n k') (subst k v t)
|
||||
| otherwise = TyForall (MkVar n k') t
|
||||
subst k v (TyApp f x) = (TyApp `on` subst k v) f x
|
||||
subst _ _ x = x
|
||||
|
||||
isKind :: Type -> Bool
|
||||
isKind (s :-> t) = isKind s && isKind t
|
||||
isKind TyKindType = True
|
||||
isKind _ = False
|
||||
|
||||
kindOf :: Gamma -> Type -> SysF Kind
|
||||
kindOf g (TyVar n) = lookupTyVar g n
|
||||
kindOf _ TyKindType = pure TyKindType
|
||||
kindOf g (TyCon n) = lookupCon g n
|
||||
kindOf _ e = error (show e)
|
||||
|
||||
lookupCon :: Gamma -> Name -> SysF Kind
|
||||
lookupCon g n = case g ^. gammaTyCons . at n of
|
||||
Just k -> Right k
|
||||
Nothing -> Left (TypeErrorUndefinedVariable n)
|
||||
|
||||
lookupVar :: Gamma -> Name -> SysF Type
|
||||
lookupVar g n = case g ^. gammaVars . at n of
|
||||
Just t -> Right t
|
||||
Nothing -> Left (TypeErrorUndefinedVariable n)
|
||||
|
||||
lookupTyVar :: Gamma -> Name -> SysF Kind
|
||||
lookupTyVar g n = case g ^. gammaTyVars . at n of
|
||||
Just k -> Right k
|
||||
Nothing -> Left (TypeErrorUndefinedVariable n)
|
||||
|
||||
demoContext :: Gamma
|
||||
demoContext = Gamma
|
||||
{ _gammaVars =
|
||||
[ ("id", TyForall ("a" :^ TyKindType) $ TyVar "a" :-> TyVar "a")
|
||||
, ("Just", TyForall ("a" :^ TyKindType) $
|
||||
TyVar "a" :-> (TyCon "Maybe" `TyApp` TyVar "a"))
|
||||
, ("Nothing", TyForall ("a" :^ TyKindType) $
|
||||
TyCon "Maybe" `TyApp` TyVar "a")
|
||||
]
|
||||
, _gammaTyVars = []
|
||||
, _gammaTyCons =
|
||||
[ ("Int#", TyKindType)
|
||||
, ("Maybe", TyKindType :-> TyKindType)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user