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

fix incomplete byTag

Browse Source
This commit is contained in:
crumbtoo
2024-02-07 14:26:47 -07:00
parent 77d27dccde
commit 719d5a4089
2 changed files with 7 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/Compiler/RLPC.hs
View File

@@ -183,6 +183,7 @@ putRlpcErrs opts = filter byTag
byTag :: MsgEnvelope RlpcError -> Bool byTag :: MsgEnvelope RlpcError -> Bool
byTag (view msgSeverity -> SevDebug t) = byTag (view msgSeverity -> SevDebug t) =
t `S.member` dflags t `S.member` dflags
byTag _ = True
prettyRlpcMsg :: MsgEnvelope RlpcError -> String prettyRlpcMsg :: MsgEnvelope RlpcError -> String
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m

10
src/Rlp2Core.hs
View File

@@ -95,14 +95,16 @@ exprToCore :: (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
exprToCore (VarE n) = pure $ Var (dsNameToName n) exprToCore (VarE n) = pure $ Var (dsNameToName n)
exprToCore (CaseE (unXRec -> e) as) = undefined exprToCore (CaseE (unXRec -> e) as) = do
e' <- exprToCore e
Case e' <$> caseAltToCore `traverse` as
-- TODO: where-binds -- TODO: where-binds
caseAltToCore :: (NameSupply :> es) caseAltToCore :: (NameSupply :> es)
=> (Alt RlpcPs, Where RlpcPs) -> Eff es Alter' => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
caseAltToCore (AltA (extract -> p) e, wh) = undefined caseAltToCore (AltA (unXRec -> p) e, wh) = do
where e' <- exprToCore . unXRec $ e
conToRose p <&> foldFix (branchToCore e')
conToRose :: forall es. (NameSupply :> es) => Pat RlpcPs -> Eff es Rose conToRose :: forall es. (NameSupply :> es) => Pat RlpcPs -> Eff es Rose
conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as