module DDC.Core.Compounds.Simple
( module DDC.Type.Compounds
, xLAMs
, xLams
, makeXLamFlags
, takeXLAMs
, takeXLams
, takeXLamFlags
, xApps
, takeXApps
, takeXApps1
, takeXAppsAsList
, takeXConApps
, takeXPrimApps
, xLets
, splitXLets
, bindsOfLets
, specBindsOfLets
, valwitBindsOfLets
, bindsOfPat
, takeCtorNameOfAlt
, wApp
, wApps
, takeXWitness
, takeWAppsAsList
, takePrimWiConApps
, takeXType
, xUnit, dcUnit
, mkDaConAlg
, mkDaConSolid
, takeNameOfDaCon
, typeOfDaCon)
where
import DDC.Type.Exp
import DDC.Core.Exp.Simple
import DDC.Core.Exp.DaCon
import DDC.Type.Compounds
xLAMs :: [Bind n] -> Exp a n -> Exp a n
xLAMs bs x
= foldr XLAM x bs
xLams :: [Bind n] -> Exp a n -> Exp a n
xLams bs x
= foldr XLam 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 :: [(Bool, Bind n)] -> Exp a n -> Exp a n
makeXLamFlags fbs x
= foldr (\(f, b) x'
-> if f then XLAM b x'
else XLam 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)
xApps :: Exp a n -> [Exp a n] -> Exp a n
xApps t1 ts = foldl XApp t1 ts
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]
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 :: [Lets a n] -> Exp a n -> Exp a n
xLets lts x
= foldr XLet 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)
bindsOfLets :: Lets a n -> ([Bind n], [Bind n])
bindsOfLets ll
= case ll of
LLet b _ -> ([], [b])
LRec bxs -> ([], map fst bxs)
LLetRegions bs bbs -> (bs, bbs)
LWithRegion{} -> ([], [])
specBindsOfLets :: Lets a n -> [Bind n]
specBindsOfLets ll
= case ll of
LLet _ _ -> []
LRec _ -> []
LLetRegions bs _ -> bs
LWithRegion{} -> []
valwitBindsOfLets :: Lets a n -> [Bind n]
valwitBindsOfLets ll
= case ll of
LLet b _ -> [b]
LRec bxs -> map fst bxs
LLetRegions _ bs -> bs
LWithRegion{} -> []
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
wApp :: Witness a n -> Witness a n -> Witness a n
wApp = WApp
wApps :: Witness a n -> [Witness a n] -> Witness a n
wApps = foldl wApp
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 :: Exp a n
xUnit = XCon dcUnit