msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

tidying

Browse Source
This commit is contained in:
crumbtoo
2024-02-07 11:19:36 -07:00
parent 868b63e6ef
commit d6529d50ff
2 changed files with 10 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
rlp.cabal
View File

@@ -87,6 +87,7 @@ library
TypeFamilies TypeFamilies
LambdaCase LambdaCase
ViewPatterns ViewPatterns
DataKinds
executable rlpc executable rlpc
import: warnings import: warnings

13
src/Rlp2Core.hs
View File

@@ -116,19 +116,24 @@ conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
getName = state $ fromJust . uncons @[IdP RlpcPs] getName = state $ fromJust . uncons @[IdP RlpcPs]
test :: Expr' -> Branch Alter' -> Alter' branchToCore :: Expr' -> Branch Alter' -> Alter'
test e (Branch cn as) = Alter (AltData cn) myBinds e' branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'
where where
-- gather binders for the /current/ pattern, and build an expression
-- matching subpatterns
(e', myBinds) = mapAccumL f e as (e', myBinds) = mapAccumL f e as
f :: Expr' -> Tree Alter' -> (Expr', Name) f :: Expr' -> Tree Alter' -> (Expr', Name)
f e (Left n) = (e, dsNameToName n) f e (Left n) = (e, dsNameToName n)
f e (Right (n,cs)) = (e', dsNameToName n) where f e (Right (n,cs)) = (e', dsNameToName n) where
e' = Case (Var $ dsNameToName n) [test e cs] e' = Case (Var $ dsNameToName n) [branchToCore e cs]
-- | debug helper
runNames :: Eff '[State [PsName]] c -> c
runNames = runPureEff . evalState nameSupply runNames = runPureEff . evalState nameSupply
-- | debug tool -- | debug helper
nameSupply :: [IdP RlpcPs] nameSupply :: [IdP RlpcPs]
nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ] nameSupply = [ T.pack $ "$x_" <> show n | n <- [0..] ]