module Kempe.Shuttle ( monomorphize
                     ) where

import           Data.Bitraversable (bitraverse)
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 (StackType ())) (StackType ()), Int)
inlineAssignFlatten :: Int
-> Module a c b
-> Either
     (Error ()) (Module () (ConsAnn (StackType ())) (StackType ()), Int)
inlineAssignFlatten Int
ctx Module a c b
m = do
    -- check before inlining otherwise users would get weird errors
    Either (Error ()) ((), Int) -> Either (Error ()) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either (Error ()) ((), Int) -> Either (Error ()) ())
-> Either (Error ()) ((), Int) -> Either (Error ()) ()
forall a b. (a -> b) -> a -> b
$ Int -> TypeM () () -> Either (Error ()) ((), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
ctx (Module a c b -> TypeM () ()
forall a c b. Module a c b -> TypeM () ()
checkModule Module a c b
m)
    (Module () (StackType ()) (StackType ())
mTy, Int
i) <- Int
-> TypeM () (Module () (StackType ()) (StackType ()))
-> Either (Error ()) (Module () (StackType ()) (StackType ()), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
ctx (Module a c b -> TypeM () (Module () (StackType ()) (StackType ()))
forall a c b.
Module a c b -> TypeM () (Module () (StackType ()) (StackType ()))
assignModule (Module a c b
 -> TypeM () (Module () (StackType ()) (StackType ())))
-> Module a c b
-> TypeM () (Module () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ Module a c b -> Module a c b
forall a c b. Module a c b -> Module a c b
inline Module a c b
m)
    Int
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
-> Either
     (Error ()) (Module () (ConsAnn (StackType ())) (StackType ()), Int)
forall a. Int -> MonoM a -> Either (Error ()) (a, Int)
runMonoM Int
i (Module () (StackType ()) (StackType ())
-> MonoM (Module () (ConsAnn (StackType ())) (StackType ()))
flattenModule Module () (StackType ()) (StackType ())
mTy)

monomorphize :: Int
             -> Module a c b
             -> Either (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
monomorphize :: Int
-> Module a c b
-> Either
     (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
monomorphize Int
ctx Module a c b
m = do
    (Module () (ConsAnn (StackType ())) (StackType ())
flat, Int
_) <- Int
-> Module a c b
-> Either
     (Error ()) (Module () (ConsAnn (StackType ())) (StackType ()), Int)
forall a c b.
Int
-> Module a c b
-> Either
     (Error ()) (Module () (ConsAnn (StackType ())) (StackType ()), Int)
inlineAssignFlatten Int
ctx Module a c b
m
    let flatFn' :: Module () (ConsAnn (StackType ())) (StackType ())
flatFn' = (KempeDecl () (ConsAnn (StackType ())) (StackType ()) -> Bool)
-> Module () (ConsAnn (StackType ())) (StackType ())
-> Module () (ConsAnn (StackType ())) (StackType ())
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (KempeDecl () (ConsAnn (StackType ())) (StackType ()) -> Bool)
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KempeDecl () (ConsAnn (StackType ())) (StackType ()) -> Bool
forall a c b. KempeDecl a c b -> Bool
isTyDecl) Module () (ConsAnn (StackType ())) (StackType ())
flat
    (KempeDecl () (ConsAnn (StackType ())) (StackType ())
 -> Either
      (Error ()) (KempeDecl () (ConsAnn MonoStackType) MonoStackType))
-> Module () (ConsAnn (StackType ())) (StackType ())
-> Either
     (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ConsAnn (StackType ())
 -> Either (Error ()) (ConsAnn MonoStackType))
-> (StackType () -> Either (Error ()) MonoStackType)
-> KempeDecl () (ConsAnn (StackType ())) (StackType ())
-> Either
     (Error ()) (KempeDecl () (ConsAnn MonoStackType) MonoStackType)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ConsAnn (StackType ()) -> Either (Error ()) (ConsAnn MonoStackType)
forall (m :: * -> *).
MonadError (Error ()) m =>
ConsAnn (StackType ()) -> m (ConsAnn MonoStackType)
tryMonoConsAnn StackType () -> Either (Error ()) MonoStackType
forall (m :: * -> *).
MonadError (Error ()) m =>
StackType () -> m MonoStackType
tryMono) Module () (ConsAnn (StackType ())) (StackType ())
flatFn'

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