Shuttle.hs

{-# LANGUAGE TupleSections #-}

module Kempe.Shuttle ( monomorphize
                     ) where

import           Data.Functor       (void)
import           Kempe.AST
import           Kempe.Error
import           Kempe.Inline
import           Kempe.Monomorphize
import           Kempe.TyAssign

inlineAssignFlatten :: Int
                    -> Module a c b
                    -> Either (Error ()) (Module () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv))
inlineAssignFlatten ctx m = do
    -- check before inlining otherwise users would get weird errors
    void $ runTypeM ctx (checkModule m)
    (mTy, i) <- runTypeM ctx (assignModule $ inline m)
    runMonoM i (flattenModule mTy)

monomorphize :: Int
             -> Module a c b
             -> Either (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
monomorphize ctx m = do
    (flat, (_, env)) <- inlineAssignFlatten ctx m
    let flatFn' = filter (not . isTyDecl) flat
    (, env) <$> traverse (traverse tryMono) flatFn'

isTyDecl :: KempeDecl a c b -> Bool
isTyDecl TyDecl{} = True
isTyDecl _        = False