module DDC.Core.Exp.Annot.Compounds
( module DDC.Type.Compounds
, annotOfExp
, mapAnnotOfExp
, xLAMs
, xLams
, makeXLamFlags
, takeXLAMs
, takeXLams
, takeXLamFlags
, Param(..)
, takeXLamParam
, xApps
, makeXAppsWithAnnots
, takeXApps
, takeXApps1
, takeXAppsAsList
, takeXAppsWithAnnots
, takeXConApps
, takeXPrimApps
, xLets, xLetsAnnot
, splitXLets, splitXLetsAnnot
, bindsOfLets
, specBindsOfLets
, valwitBindsOfLets
, patOfAlt
, takeCtorNameOfAlt
, bindsOfPat
, makeRuns
, wApp
, wApps
, annotOfWitness
, takeXWitness
, takeWAppsAsList
, takePrimWiConApps
, takeXType
, xUnit, dcUnit
, takeNameOfDaCon
, takeTypeOfDaCon)
where
import DDC.Core.Exp.Annot.Exp
import DDC.Core.Exp.DaCon
import DDC.Type.Compounds
annotOfExp :: Exp a n -> a
annotOfExp xx
= case xx of
XVar a _ -> a
XCon a _ -> a
XLAM a _ _ -> a
XLam a _ _ -> a
XApp a _ _ -> a
XLet a _ _ -> a
XCase a _ _ -> a
XCast a _ _ -> a
XType a _ -> a
XWitness a _ -> a
mapAnnotOfExp :: (a -> a) -> Exp a n -> Exp a n
mapAnnotOfExp f xx
= case xx of
XVar a u -> XVar (f a) u
XCon a c -> XCon (f a) c
XLAM a b x -> XLAM (f a) b x
XLam a b x -> XLam (f a) b x
XApp a x1 x2 -> XApp (f a) x1 x2
XLet a lt x -> XLet (f a) lt x
XCase a x as -> XCase (f a) x as
XCast a c x -> XCast (f a) c x
XType a t -> XType (f a) t
XWitness a w -> XWitness (f a) w
xLAMs :: a -> [Bind n] -> Exp a n -> Exp a n
xLAMs a bs x
= foldr (XLAM a) x bs
xLams :: a -> [Bind n] -> Exp a n -> Exp a n
xLams a bs x
= foldr (XLam a) x bs
takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n)
takeXLAMs xx
= let go bs (XLAM _ b x) = go (b:bs) x
go bs x = (reverse bs, x)
in case go [] xx of
([], _) -> Nothing
(bs, body) -> Just (bs, body)
takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n)
takeXLams xx
= let go bs (XLam _ b x) = go (b:bs) x
go bs x = (reverse bs, x)
in case go [] xx of
([], _) -> Nothing
(bs, body) -> Just (bs, body)
makeXLamFlags :: a -> [(Bool, Bind n)] -> Exp a n -> Exp a n
makeXLamFlags a fbs x
= foldr (\(f, b) x'
-> if f then XLAM a b x'
else XLam a b x')
x fbs
takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n)
takeXLamFlags xx
= let go bs (XLAM _ b x) = go ((True, b):bs) x
go bs (XLam _ b x) = go ((False, b):bs) x
go bs x = (reverse bs, x)
in case go [] xx of
([], _) -> Nothing
(bs, body) -> Just (bs, body)
data Param n
= ParamType (Bind n)
| ParamValue (Bind n)
| ParamBox
deriving Show
takeXLamParam :: Exp a n -> Maybe ([Param n], Exp a n)
takeXLamParam xx
= let go bs (XLAM _ b x) = go (ParamType b : bs) x
go bs (XLam _ b x) = go (ParamValue b : bs) x
go bs (XCast _ CastBox x) = go (ParamBox : bs) x
go bs x = (reverse bs, x)
in case go [] xx of
([], _) -> Nothing
(bs, body) -> Just (bs, body)
xApps :: a -> Exp a n -> [Exp a n] -> Exp a n
xApps a t1 ts = foldl (XApp a) t1 ts
makeXAppsWithAnnots :: Exp a n -> [(Exp a n, a)] -> Exp a n
makeXAppsWithAnnots f xas
= case xas of
[] -> f
(arg,a ) : as -> makeXAppsWithAnnots (XApp a f arg) as
takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n])
takeXApps xx
= case takeXAppsAsList xx of
(x1 : xsArgs) -> Just (x1, xsArgs)
_ -> Nothing
takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n])
takeXApps1 x1 x2
= case takeXApps x1 of
Nothing -> (x1, [x2])
Just (x11, x12s) -> (x11, x12s ++ [x2])
takeXAppsAsList :: Exp a n -> [Exp a n]
takeXAppsAsList xx
= case xx of
XApp _ x1 x2 -> takeXAppsAsList x1 ++ [x2]
_ -> [xx]
takeXAppsWithAnnots :: Exp a n -> (Exp a n, [(Exp a n, a)])
takeXAppsWithAnnots xx
= case xx of
XApp a f arg
-> let (f', args') = takeXAppsWithAnnots f
in (f', args' ++ [(arg,a)])
_ -> (xx, [])
takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n])
takeXPrimApps xx
= case takeXAppsAsList xx of
XVar _ (UPrim p _) : xs -> Just (p, xs)
_ -> Nothing
takeXConApps :: Exp a n -> Maybe (DaCon n, [Exp a n])
takeXConApps xx
= case takeXAppsAsList xx of
XCon _ dc : xs -> Just (dc, xs)
_ -> Nothing
xLets :: a -> [Lets a n] -> Exp a n -> Exp a n
xLets a lts x
= foldr (XLet a) x lts
xLetsAnnot :: [(Lets a n, a)] -> Exp a n -> Exp a n
xLetsAnnot lts x
= foldr (\(l, a) x' -> XLet a l x') x lts
splitXLets :: Exp a n -> ([Lets a n], Exp a n)
splitXLets xx
= case xx of
XLet _ lts x
-> let (lts', x') = splitXLets x
in (lts : lts', x')
_ -> ([], xx)
splitXLetsAnnot :: Exp a n -> ([(Lets a n, a)], Exp a n)
splitXLetsAnnot xx
= case xx of
XLet a lts x
-> let (lts', x') = splitXLetsAnnot x
in ((lts, a) : lts', x')
_ -> ([], xx)
bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
bindsOfLets ll
= case ll of
LLet b _ -> ([], [b])
LRec bxs -> ([], map fst bxs)
LPrivate bs _ bbs -> (bs, bbs)
specBindsOfLets :: Lets a n -> [Bind n]
specBindsOfLets ll
= case ll of
LLet _ _ -> []
LRec _ -> []
LPrivate bs _ _ -> bs
valwitBindsOfLets :: Lets a n -> [Bind n]
valwitBindsOfLets ll
= case ll of
LLet b _ -> [b]
LRec bxs -> map fst bxs
LPrivate _ _ bs -> bs
patOfAlt :: Alt a n -> Pat n
patOfAlt (AAlt pat _) = pat
takeCtorNameOfAlt :: Alt a n -> Maybe n
takeCtorNameOfAlt aa
= case aa of
AAlt (PData dc _) _ -> takeNameOfDaCon dc
_ -> Nothing
bindsOfPat :: Pat n -> [Bind n]
bindsOfPat pp
= case pp of
PDefault -> []
PData _ bs -> bs
makeRuns :: a -> Int -> Exp a n -> Exp a n
makeRuns _a 0 x = x
makeRuns a n x = XCast a CastRun (makeRuns a (n 1) x)
wApp :: a -> Witness a n -> Witness a n -> Witness a n
wApp = WApp
wApps :: a -> Witness a n -> [Witness a n] -> Witness a n
wApps a = foldl (wApp a)
annotOfWitness :: Witness a n -> a
annotOfWitness ww
= case ww of
WVar a _ -> a
WCon a _ -> a
WApp a _ _ -> a
WType a _ -> a
takeXWitness :: Exp a n -> Maybe (Witness a n)
takeXWitness xx
= case xx of
XWitness _ t -> Just t
_ -> Nothing
takeWAppsAsList :: Witness a n -> [Witness a n]
takeWAppsAsList ww
= case ww of
WApp _ w1 w2 -> takeWAppsAsList w1 ++ [w2]
_ -> [ww]
takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n])
takePrimWiConApps ww
= case takeWAppsAsList ww of
WCon _ wc : args | WiConBound (UPrim n _) _ <- wc
-> Just (n, args)
_ -> Nothing
takeXType :: Exp a n -> Maybe (Type n)
takeXType xx
= case xx of
XType _ t -> Just t
_ -> Nothing
xUnit :: a -> Exp a n
xUnit a = XCon a dcUnit