module DDC.Core.Salt.Exp
( module DDC.Core.Exp.Generic.Exp
, FromAnnot (..)
, ErrorFromAnnot (..)
, Annot, Bind, Bound, Prim
, Exp, Abs, Arg, Lets, Alt, Pat, Cast, Witness, WiCon
, Type)
where
import DDC.Core.Exp.Generic.Exp
import qualified DDC.Core.Exp.Generic.Exp as G
import qualified DDC.Core.Salt.Name as A
import qualified DDC.Core.Exp.Annot.Exp as N
import qualified DDC.Type.Exp as C
type instance GAnnot A.Name = ()
type instance GBind A.Name = C.Bind A.Name
type instance GBound A.Name = C.Bound A.Name
type instance GPrim A.Name = A.PrimOp
type Annot = GAnnot A.Name
type Bind = GBind A.Name
type Bound = GBound A.Name
type Prim = GPrim A.Name
type Exp = GExp A.Name
type Abs = GAbs A.Name
type Arg = GArg A.Name
type Lets = GLets A.Name
type Alt = GAlt A.Name
type Pat = GPat A.Name
type Cast = GCast A.Name
type Witness = GWitness A.Name
type WiCon = GWiCon A.Name
type Type = C.Type A.Name
class FromAnnot c1 c2 | c1 -> c2 where
fromAnnot :: c1 -> Either ErrorFromAnnot c2
data ErrorFromAnnot
= ErrorFromAnnotFoundNakedType
| ErrorFromAnnotFoundNakedWitness
instance FromAnnot (N.Exp a A.Name) Exp where
fromAnnot xx
= case xx of
N.XVar _ (C.UPrim (A.NamePrimVal (A.PrimValOp op)) _)
-> G.XPrim <$> pure op
N.XVar _ u
-> G.XVar <$> fromAnnot u
N.XCon _ c
-> G.XCon <$> fromAnnot c
N.XLAM _ b x
-> G.XAbs <$> (G.ALAM <$> fromAnnot b) <*> fromAnnot x
N.XLam _ b x
-> G.XAbs <$> (G.ALam <$> fromAnnot b) <*> fromAnnot x
N.XApp _ x1 (N.XType _ t)
-> G.XApp <$> fromAnnot x1 <*> (G.RType <$> fromAnnot t)
N.XApp _ x1 (N.XWitness _ w)
-> G.XApp <$> fromAnnot x1 <*> (G.RWitness <$> fromAnnot w)
N.XApp _ x1 x2
-> G.XApp <$> fromAnnot x1 <*> (G.RExp <$> fromAnnot x2)
N.XLet _ lts x
-> G.XLet <$> fromAnnot lts <*> fromAnnot x
N.XCase _ x alts
-> G.XCase <$> fromAnnot x <*> fromAnnots alts
N.XCast _ c x
-> G.XCast <$> fromAnnot c <*> fromAnnot x
N.XType{}
-> Left $ ErrorFromAnnotFoundNakedType
N.XWitness{}
-> Left $ ErrorFromAnnotFoundNakedWitness
instance FromAnnot (N.Lets a A.Name) Lets where
fromAnnot lts
= case lts of
N.LLet u x
-> G.LLet <$> fromAnnot u <*> fromAnnot x
N.LRec bxs
-> G.LRec <$> (sequence $ fmap fromAnnot2 bxs)
N.LPrivate rs mt wt
-> G.LPrivate <$> fromAnnots rs <*> fromAnnotM mt <*> fromAnnots wt
instance FromAnnot (N.Alt a A.Name) Alt where
fromAnnot aa
= case aa of
N.AAlt w x -> G.AAlt <$> fromAnnot w <*> fromAnnot x
instance FromAnnot (N.Pat A.Name) Pat where
fromAnnot pp
= case pp of
N.PDefault -> pure G.PDefault
N.PData dc bs -> G.PData <$> pure dc <*> fromAnnots bs
instance FromAnnot (N.Cast a A.Name) Cast where
fromAnnot cc
= case cc of
N.CastWeakenEffect t -> G.CastWeakenEffect <$> pure t
N.CastPurify w -> G.CastPurify <$> fromAnnot w
N.CastBox -> pure G.CastBox
N.CastRun -> pure G.CastRun
instance FromAnnot (N.Witness a A.Name) Witness where
fromAnnot ww
= case ww of
N.WVar _ u -> G.WVar <$> pure u
N.WCon _ wc -> G.WCon <$> fromAnnot wc
N.WApp _ w1 w2 -> G.WApp <$> fromAnnot w1 <*> fromAnnot w2
N.WType _ t -> G.WType <$> pure t
instance FromAnnot (N.DaCon A.Name) (N.DaCon A.Name) where
fromAnnot dc = pure dc
instance FromAnnot (N.WiCon A.Name) WiCon where
fromAnnot ww
= case ww of
N.WiConBound u t -> G.WiConBound <$> pure u <*> pure t
instance FromAnnot (C.Type A.Name) (C.Type A.Name) where
fromAnnot tt = pure tt
instance FromAnnot (N.Bind A.Name) (C.Bind A.Name) where
fromAnnot bb = pure bb
instance FromAnnot (N.Bound A.Name) (C.Bound A.Name) where
fromAnnot uu = pure uu
fromAnnot2 (x, y)
= (,) <$> fromAnnot x <*> fromAnnot y
fromAnnots xs
= sequence $ fmap fromAnnot xs
fromAnnotM Nothing = pure Nothing
fromAnnotM (Just x) = Just <$> fromAnnot x