{-# LANGUAGE TupleSections #-}

module Kempe.Shuttle ( monomorphize
                     ) where

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

inlineAssignFlatten :: Int
                    -> Declarations a c b
                    -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv))
inlineAssignFlatten :: Int
-> Declarations a c b
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) (StackType ()),
      (Int, SizeEnv))
inlineAssignFlatten Int
ctx Declarations a c b
m = do
    -- check before inlining otherwise users would get weird errors
    -- TODO: make this more efficient now that liveness anal. is not dominating
    -- all performance
    Either (Error ()) () -> Either (Error ()) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either (Error ()) () -> Either (Error ()) ())
-> Either (Error ()) () -> Either (Error ()) ()
forall a b. (a -> b) -> a -> b
$ do
        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 (Declarations a c b -> TypeM () ()
forall a c b. Declarations a c b -> TypeM () ()
checkModule Declarations a c b
m)
        Maybe (Error ()) -> Either (Error ()) ()
mErr (Maybe (Error ()) -> Either (Error ()) ())
-> Maybe (Error ()) -> Either (Error ()) ()
forall a b. (a -> b) -> a -> b
$ Declarations a c () -> Maybe (Error ())
forall a c b. Declarations a c b -> Maybe (Error b)
checkModuleExhaustive (KempeDecl a c b -> KempeDecl a c ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KempeDecl a c b -> KempeDecl a c ())
-> Declarations a c b -> Declarations a c ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Declarations a c b
m)
    (Declarations () (StackType ()) (StackType ())
mTy, Int
i) <- Int
-> TypeM () (Declarations () (StackType ()) (StackType ()))
-> Either
     (Error ()) (Declarations () (StackType ()) (StackType ()), Int)
forall a x. Int -> TypeM a x -> Either (Error a) (x, Int)
runTypeM Int
ctx (Declarations a c b
-> TypeM () (Declarations () (StackType ()) (StackType ()))
forall a c b.
Declarations a c b
-> TypeM () (Declarations () (StackType ()) (StackType ()))
assignModule (Declarations a c b
 -> TypeM () (Declarations () (StackType ()) (StackType ())))
-> Declarations a c b
-> TypeM () (Declarations () (StackType ()) (StackType ()))
forall a b. (a -> b) -> a -> b
$ Declarations a c b -> Declarations a c b
forall a c b. Declarations a c b -> Declarations a c b
inline Declarations a c b
m)
    Int
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) (StackType ()),
      (Int, SizeEnv))
forall a. Int -> MonoM a -> Either (Error ()) (a, (Int, SizeEnv))
runMonoM Int
i (Declarations () (StackType ()) (StackType ())
-> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ()))
flattenModule Declarations () (StackType ()) (StackType ())
mTy)

monomorphize :: Int
             -> Declarations a c b
             -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
monomorphize :: Int
-> Declarations a c b
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
monomorphize Int
ctx Declarations a c b
m = do
    (Declarations () (ConsAnn MonoStackType) (StackType ())
flat, (Int
_, SizeEnv
env)) <- Int
-> Declarations a c b
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) (StackType ()),
      (Int, SizeEnv))
forall a c b.
Int
-> Declarations a c b
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) (StackType ()),
      (Int, SizeEnv))
inlineAssignFlatten Int
ctx Declarations a c b
m
    let flatFn' :: Declarations () (ConsAnn MonoStackType) (StackType ())
flatFn' = (KempeDecl () (ConsAnn MonoStackType) (StackType ()) -> Bool)
-> Declarations () (ConsAnn MonoStackType) (StackType ())
-> Declarations () (ConsAnn MonoStackType) (StackType ())
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (KempeDecl () (ConsAnn MonoStackType) (StackType ()) -> Bool)
-> KempeDecl () (ConsAnn MonoStackType) (StackType ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KempeDecl () (ConsAnn MonoStackType) (StackType ()) -> Bool
forall a c b. KempeDecl a c b -> Bool
isTyDecl) Declarations () (ConsAnn MonoStackType) (StackType ())
flat
    (, SizeEnv
env) (Declarations () (ConsAnn MonoStackType) MonoStackType
 -> (Declarations () (ConsAnn MonoStackType) MonoStackType,
     SizeEnv))
-> Either
     (Error ()) (Declarations () (ConsAnn MonoStackType) MonoStackType)
-> Either
     (Error ())
     (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KempeDecl () (ConsAnn MonoStackType) (StackType ())
 -> Either
      (Error ()) (KempeDecl () (ConsAnn MonoStackType) MonoStackType))
-> Declarations () (ConsAnn MonoStackType) (StackType ())
-> Either
     (Error ()) (Declarations () (ConsAnn MonoStackType) MonoStackType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((StackType () -> Either (Error ()) MonoStackType)
-> KempeDecl () (ConsAnn MonoStackType) (StackType ())
-> Either
     (Error ()) (KempeDecl () (ConsAnn MonoStackType) MonoStackType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StackType () -> Either (Error ()) MonoStackType
forall (m :: * -> *).
MonadError (Error ()) m =>
StackType () -> m MonoStackType
tryMono) Declarations () (ConsAnn MonoStackType) (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