blog
/
tagless-final-parsing
1
Fork 0
Code

Keep strict.

main
Joshua Potter 2021-12-25 18:31:54 -05:00
parent 6f1e8de814
commit 6eab07e732
2 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
initial-encoding/src/Parser/Initial.hs
View File

@ -119,6 +119,10 @@ parseSingle = expr >>= either (fail . unpack) pure
-- Strict -- Strict
-- ======================================== -- ========================================
instance NFData Result where
rnf (RInt e) = e `seq` ()
rnf (RBool e) = e `seq` ()
parseStrict :: Parser Result parseStrict :: Parser Result
parseStrict = term >>= expr parseStrict = term >>= expr
where where
@ -144,7 +148,7 @@ parseStrict = term >>= expr
lhs <- cast t lhs <- cast t
rhs <- cast t' rhs <- cast t'
toResult $ bin (f lhs) (f rhs) toResult $ bin (f lhs) (f rhs)
a `seq` expr a a `deepseq` expr a
term = do term = do
p <- M.option Nothing $ Just <$> symbol "(" p <- M.option Nothing $ Just <$> symbol "("

6
tagless-final/src/Parser/Final.hs
View File

@ -130,9 +130,9 @@ binDyn bin lhs rhs = do
pure . Dynamic type' $ bin lhs' rhs' pure . Dynamic type' $ bin lhs' rhs'
parseSingle :: forall repr. Symantics repr => Parser (Dynamic repr) parseSingle :: forall repr. Symantics repr => Parser (Dynamic repr)
parseSingle = expr >>= \case parseSingle =
Left (offset, msg) -> M.setOffset offset >> fail msg let ferr (offset, msg) = M.setOffset offset >> fail msg
Right a -> pure a in expr >>= either ferr pure
where where
expr = E.makeExprParser term expr = E.makeExprParser term
[ [binary "+" eAdd, binary "-" eSub] [ [binary "+" eAdd, binary "-" eSub]