Embed.hs

module Grin.Embed((.>>=),(.>>),GG,VVar,TyNode,TyTag,TyPtr,TyRaw,embedTest) where

import Doc.Pretty
import GenUtil
import Grin.Grin
import Grin.Show
import StringTable.Atom
import Support.CanType
import Util.UniqueMonad

newtype GG = GG { unGG :: (Uniq Exp) }

data TyNode
data TyTag
data TyPtr a
data TyRaw a
data TyUnknown

runGG :: Int -> Uniq Exp -> Exp
runGG n x | n <= 0 = runGG 1 x
runGG s (GG x) = fst (runUniq s x)

unLam :: forall a . Valable a => ( a -> GG ) -> Uniq Lam
unLam f = do
    (x,v) <- varUp (error "cannot unlamunknown")
    gb <- unGG $ f x
    return $ v :-> gb

dunLam :: forall a . Valable a => Ty -> ( a -> GG ) -> Uniq Lam
dunLam ty f = do
    (x,v) <- varUp ty
    gb <- unGG $ f x
    return $ v :-> gb

{-
data TyTup -- ???
data Val :: * where
    Tag :: Tag -> Val TyTag
    Const :: Val x -> Val (TyPtr x)
    Lit :: Number -> Val (TyBasic)
    Var :: Var -> Val a
    NodeC :: Tag -> ???? -> Val TyNode
    Tup :: ???? -> Val ???
-}

infixr 1  .>>=, .>>

(.>>=) :: Valable a => GG -> (a -> GG) -> GG
(.>>=) (GG g1) f2 = GG $ do
    ga <- g1
    (x,v) <- varUp (getType ga)
    gb <- unGG $ f2 x
    return $ ga :>>= v :-> gb

(.>>) :: GG -> GG -> GG
(.>>) g1 g2 = g1 .>>= \ ( _ :: TyUnknown ) -> g2

newtype VVar a = VVar Val

class Valable a where
    varUp :: Ty -> Uniq (a,Val)

vvarUp :: forall a . Ty -> Uniq (VVar a,Val)
vvarUp TyTup {} = error "vvarUp tuple"
vvarUp ty = do
    vv <- newVal ty
    return (VVar vv,vv)

newVal (TyTup tys) = do
    vs <- mapM newVal tys
    return (Tup vs)
newVal ty = do
    i <- newUniq
    return (Var (V i) ty)

{-
instance Valable a where
    varUp ty = do
        vv <- newVal ty
        return (undefined,vv)
-}

instance Valable TyUnknown where
    varUp ty = do
        vv <- newVal ty
        return (undefined,vv)

instance TyBasic a => Valable (VVar (TyRaw a)) where
    varUp _ = vvarUp (Ty (rawType (undefined :: a)))

instance Valable (VVar TyNode) where
    varUp _ = vvarUp TyNode
instance Valable (VVar TyTag) where
    varUp _ = vvarUp TyTag
instance (Valable a, Valable b) => Valable (a,b) where
    varUp (TyTup [x,y]) = do
        (vva,va) <- varUp x
        (vvb,vb) <- varUp y
        return ((vva,vvb),Tup [va,vb])

class TyBasic a where
    rawType :: a -> Atom

data RawInt
type Rint = TyRaw RawInt

instance TyBasic RawInt where
    rawType _ = (toAtom "int")

gCase :: VVal a -> [Uniq Lam] -> GG
gCase (VVal v) ls = GG $ do
    ls <- sequence ls
    return $ Case v ls

gReturn :: VVal a -> GG
gReturn (VVal v) = GG $ return $ Return v

app2 :: Atom -> VVal a -> VVal b -> GG
app2 n (VVal a) (VVal b) = GG $ return (App n [a,b])

lLam :: Val -> Uniq Exp -> Uniq Lam
lLam v ue = do
    e <- ue
    return $ v :-> e

fact :: (Rint,Rint) -> GG
fact (n,r) = gCase n [unLam $ \ (x :: Rint) -> primMinus n 1 .>>= \ n' -> primTimes n r .>>= \r' -> app (toAtom "fact") [n',r'], lLam 1 (gReturn r) ]

embedTest = do
    putDoc $ prettyFun (toAtom "fact",execUniq1 $ unLam fact)