From 41926c8abc288bec35259e3171e25929e7e45aea Mon Sep 17 00:00:00 2001 From: Joshua Potter Date: Tue, 21 Dec 2021 22:28:03 -0500 Subject: [PATCH] Add with GADT support. --- cabal.project | 2 +- initial-encoding/app/Main.hs | 61 ++++ .../initial-encoding.cabal | 7 +- initial-encoding/src/Parser.hs | 311 ++++++++++++++++++ .../test/Driver.hs | 0 .../test/Test/ParserTest.hs | 29 +- parser-initial/app/Main.hs | 52 --- parser-initial/src/Parser.hs | 188 ----------- 8 files changed, 397 insertions(+), 253 deletions(-) create mode 100644 initial-encoding/app/Main.hs rename parser-initial/parser-initial.cabal => initial-encoding/initial-encoding.cabal (88%) create mode 100644 initial-encoding/src/Parser.hs rename {parser-initial => initial-encoding}/test/Driver.hs (100%) rename {parser-initial => initial-encoding}/test/Test/ParserTest.hs (69%) delete mode 100644 parser-initial/app/Main.hs delete mode 100644 parser-initial/src/Parser.hs diff --git a/cabal.project b/cabal.project index f34a4ea..bc3e346 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ packages: + initial-encoding leibniz-proof parser-closed - parser-initial diff --git a/initial-encoding/app/Main.hs b/initial-encoding/app/Main.hs new file mode 100644 index 0000000..2fe310f --- /dev/null +++ b/initial-encoding/app/Main.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Text.Megaparsec as M + +import Data.Bifunctor (first) +import Data.Text (Text, pack) +import Data.Text.IO (hGetContents) +import Options.Applicative +import Parser +import System.Environment (getArgs) +import System.IO (IOMode(ReadMode), openFile) + +data Args = Args + { argsFileName :: !FilePath + , argsMethod :: !Text + } + +args :: Parser Args +args = Args + <$> strArgument (metavar "FILENAME" <> help "The file we want to parse.") + <*> strOption + ( short 'm' + <> long "method" + <> metavar "METHOD" + <> showDefault + <> value "naive" + <> help "The parse strategy we want to try. Should be one of \ + \\"naive\", \"mul_pass\", or \"mem_cons\"." + ) + +runExpr :: (Text -> Either Text Expr) -> Text -> IO () +runExpr f input = case f input >>= eval of + Right (EInt e) -> print e + Right (EBool e) -> print e + _ -> error "Could not evaluate expression fully." + +run :: Args -> IO () +run args = do + handle <- openFile (argsFileName args) ReadMode + contents <- hGetContents handle + case argsMethod args of + "naive" -> runExpr runNaive contents + "mul_pass" -> runExpr runMulPass contents + "mem_cons" -> runExpr runMemCons contents + "gadt" -> case runGadt contents of + Left e -> print e + Right (Wrapper a) -> print $ gadtEval a + _ -> error "Encountered an invalid parsing strategy." + +main :: IO () +main = run =<< execParser opts + where + opts = info (args <**> helper) + ( fullDesc + <> progDesc "Different parsing strategies using initial encoding" + <> header "Initial encoding parsing" + ) diff --git a/parser-initial/parser-initial.cabal b/initial-encoding/initial-encoding.cabal similarity index 88% rename from parser-initial/parser-initial.cabal rename to initial-encoding/initial-encoding.cabal index 79efce3..c7fb52c 100644 --- a/parser-initial/parser-initial.cabal +++ b/initial-encoding/initial-encoding.cabal @@ -1,13 +1,14 @@ cabal-version: 3.4 - name: parser-initial + name: initial-encoding version: 0.1.0.0 executable parser-initial main-is: Main.hs build-depends: base ^>=4.14.3.0, + initial-encoding, megaparsec, + mtl, optparse-applicative, - parser-initial, text, hs-source-dirs: app default-language: Haskell2010 @@ -32,8 +33,8 @@ test-suite parser-initial-test build-depends: base ^>=4.14.3.0, HUnit, hspec, + initial-encoding, megaparsec, - parser-initial, tasty, tasty-discover, tasty-hspec, diff --git a/initial-encoding/src/Parser.hs b/initial-encoding/src/Parser.hs new file mode 100644 index 0000000..2421a2a --- /dev/null +++ b/initial-encoding/src/Parser.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Parser +( Expr(..) +, GExpr(..) +, ParserT +, Wrapper(..) +, eval +, gadtEval +, gadtExpr +, memConsExpr +, mulPassExpr +, naiveExpr +, runGadt +, runMemCons +, runMulPass +, runNaive +) where + +import qualified Control.Monad.Combinators.Expr as E +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as MC +import qualified Text.Megaparsec.Char.Lexer as ML + +import Control.Applicative ((<|>)) +import Control.Applicative.Combinators (skipMany) +import Control.DeepSeq (NFData(..), deepseq) +import Control.Monad (join) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.State (MonadState, modify) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Either (hoistEither) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.Bifunctor (bimap, first) +import Data.Char (isDigit) +import Data.Foldable (foldl') +import Data.Functor (($>), void) +import Data.Maybe (isJust) +import Data.Text (Text, pack, unpack) +import Data.Text.IO (hGetContents) +import Data.Void (Void) +import Numeric (readDec) +import System.Environment (getArgs) +import System.IO (IOMode(ReadMode), openFile) + +-- ======================================== +-- ADT +-- ======================================== + +data Expr + = EInt Integer + | EBool Bool + | EAdd Expr Expr + | ESub Expr Expr + | EAnd Expr Expr + | EOr Expr Expr + deriving (Eq, Show) + +eval :: Expr -> Either Text Expr +eval e@(EInt _) = pure e +eval e@(EBool _) = pure e +eval (EAdd lhs rhs) = do + (lhs', rhs') <- binInt lhs rhs + pure $ EInt (lhs' + rhs') +eval (ESub lhs rhs) = do + (lhs', rhs') <- binInt lhs rhs + pure $ EInt (lhs' - rhs') +eval (EAnd lhs rhs) = do + (lhs', rhs') <- binBool lhs rhs + pure $ EBool (lhs' && rhs') +eval (EOr lhs rhs) = do + (lhs', rhs') <- binBool lhs rhs + pure $ EBool (lhs' || rhs') + +binInt :: Expr -> Expr -> Either Text (Integer, Integer) +binInt lhs rhs = do + lhs' <- eval lhs + rhs' <- eval rhs + case (lhs', rhs') of + (EInt lhs'', EInt rhs'') -> pure (lhs'', rhs'') + _ -> Left "Expected two integers." + +binBool :: Expr -> Expr -> Either Text (Bool, Bool) +binBool lhs rhs = do + lhs' <- eval lhs + rhs' <- eval rhs + case (lhs', rhs') of + (EBool lhs'', EBool rhs'') -> pure (lhs'', rhs'') + _ -> Left "Expected two booleans." + +-- ======================================== +-- Lexers +-- ======================================== + +type ParserT = M.ParsecT Void Text + +space :: forall m. ParserT m () +space = ML.space MC.space1 M.empty M.empty +{-# INLINE space #-} + +lexeme :: forall m a. ParserT m a -> ParserT m a +lexeme = ML.lexeme MC.space +{-# INLINE lexeme #-} + +symbol :: forall m. Text -> ParserT m Text +symbol = ML.symbol space +{-# INLINE symbol #-} + +parens :: forall m a. ParserT m a -> ParserT m a +parens = M.between (symbol "(") (symbol ")") +{-# INLINE parens #-} + +boolean :: forall m. ParserT m Bool +boolean = lexeme $ MC.string "true" $> True <|> MC.string "false" $> False +{-# INLINE boolean #-} + +integer :: forall m. ParserT m Integer +integer = lexeme ML.decimal +{-# INLINE integer #-} + +data Op = OpAdd | OpSub | OpAnd | OpOr + +ops :: forall m. ParserT m Op +ops = M.choice + [ symbol "+" $> OpAdd + , symbol "-" $> OpSub + , symbol "&&" $> OpAnd + , symbol "||" $> OpOr + ] + +-- ======================================== +-- Naive attempt +-- ======================================== + +naiveExpr :: forall m. ParserT m Expr +naiveExpr = E.makeExprParser term + [ [binary "+" EAdd, binary "-" ESub] + , [binary "&&" EAnd, binary "||" EOr] + ] + where + binary name f = E.InfixL (f <$ symbol name) + + term = parens naiveExpr <|> + EInt <$> integer <|> + EBool <$> boolean + +runNaive :: Text -> Either Text Expr +runNaive input = + let res = M.parse (naiveExpr <* M.eof) "" input + in join $ bimap (pack . M.errorBundlePretty) eval res + +-- ======================================== +-- Multiple passes +-- ======================================== + +mulPassExpr :: forall m. MonadError Text m => ParserT m Expr +mulPassExpr = expr >>= either (fail . unpack) pure + where + expr = E.makeExprParser term + [ [ binary "+" binInt EInt EAdd + , binary "-" binInt EInt ESub + ] + , [ binary "&&" binBool EBool EAnd + , binary "||" binBool EBool EOr + ] + ] + + binary name cast f bin = E.InfixL do + void $ symbol name + pure $ \lhs rhs -> do + lhs' <- lhs + rhs' <- rhs + (lhs', rhs') <- cast lhs' rhs' + k <- eval $ bin (f lhs') (f rhs') + pure $ k `deepseq` k + + term = parens expr <|> + Right . EInt <$> integer <|> + Right . EBool <$> boolean + +runMulPass :: Text -> Either Text Expr +runMulPass input = + let res = M.runParserT (mulPassExpr <* M.eof) "" input + in res >>= join . bimap (pack . M.errorBundlePretty) eval + +-- ======================================== +-- Memory consumption +-- ======================================== + +instance NFData Expr where + rnf (EInt e) = rnf e + rnf (EBool e) = rnf e + rnf (EAdd lhs rhs) = rnf lhs `seq` rnf rhs + rnf (ESub lhs rhs) = rnf lhs `seq` rnf rhs + rnf (EAnd lhs rhs) = rnf lhs `seq` rnf rhs + rnf (EOr lhs rhs) = rnf lhs `seq` rnf rhs + +memConsExpr :: forall m. MonadError Text m => ParserT m Expr +memConsExpr = term >>= expr + where + expr t = do + op <- M.option Nothing $ Just <$> ops + case op of + Just OpAdd -> nest t EAdd + Just OpSub -> nest t ESub + Just OpAnd -> nest t EAnd + Just OpOr -> nest t EOr + _ -> pure t + + nest :: Expr -> (Expr -> Expr -> Expr) -> ParserT m Expr + nest t bin = do + t' <- term + case eval (bin t t') of + Left e -> throwError e + Right a -> a `deepseq` expr a + + term = do + p <- M.option Nothing $ Just <$> symbol "(" + if isJust p then (term >>= expr) <* symbol ")" else + EInt <$> integer <|> EBool <$> boolean + +runMemCons :: Text -> Either Text Expr +runMemCons input = + let res = M.runParserT (memConsExpr <* M.eof) "" input + in res >>= join . bimap (pack . M.errorBundlePretty) eval + +-- ======================================== +-- GADTs +-- ======================================== + +data GExpr a where + GInt :: Integer -> GExpr Integer + GBool :: Bool -> GExpr Bool + GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer + GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer + GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool + GOr :: GExpr Bool -> GExpr Bool -> GExpr Bool + +instance NFData (GExpr a) where + rnf (GInt e) = rnf e + rnf (GBool e) = rnf e + rnf (GAdd lhs rhs) = rnf lhs `seq` rnf rhs + rnf (GSub lhs rhs) = rnf lhs `seq` rnf rhs + rnf (GAnd lhs rhs) = rnf lhs `seq` rnf rhs + rnf (GOr lhs rhs) = rnf lhs `seq` rnf rhs + +data Wrapper = forall a. Show a => Wrapper (GExpr a) + +fromInt :: GExpr a -> Either Text (GExpr Integer) +fromInt a@(GInt _ ) = pure a +fromInt a@(GAdd _ _) = pure a +fromInt a@(GSub _ _) = pure a +fromInt _ = Left "Expected an integer type." + +fromBool :: GExpr a -> Either Text (GExpr Bool) +fromBool a@(GBool _ ) = pure a +fromBool a@(GAnd _ _) = pure a +fromBool a@(GOr _ _) = pure a +fromBool _ = Left "Expected a boolean type." + +gadtEval :: GExpr a -> a +gadtEval (GInt a) = a +gadtEval (GBool a) = a +gadtEval (GAdd lhs rhs) = gadtEval lhs + gadtEval rhs +gadtEval (GSub lhs rhs) = gadtEval lhs - gadtEval rhs +gadtEval (GAnd lhs rhs) = gadtEval lhs && gadtEval rhs +gadtEval (GOr lhs rhs) = gadtEval lhs || gadtEval rhs + +gadtExpr :: forall m. MonadError Text m => ParserT m Wrapper +gadtExpr = term >>= expr + where + expr t = do + op <- M.option Nothing $ Just <$> ops + case op of + Just OpAdd -> nest t fromInt GAdd GInt + Just OpSub -> nest t fromInt GSub GInt + Just OpAnd -> nest t fromBool GAnd GBool + Just OpOr -> nest t fromBool GOr GBool + _ -> pure t + + nest + :: forall b + . Show b + => Wrapper + -> (forall a. GExpr a -> Either Text (GExpr b)) + -> (GExpr b -> GExpr b -> GExpr b) + -> (b -> GExpr b) + -> ParserT m Wrapper + nest (Wrapper t) cast bin f = do + Wrapper t' <- term + case (cast t, cast t') of + (Right lhs, Right rhs) -> do + let z = f . gadtEval $ bin lhs rhs + z `deepseq` expr (Wrapper z) + (Left e, _) -> throwError e + (_, Left e) -> throwError e + + term = do + p <- M.option Nothing $ Just <$> symbol "(" + if isJust p then (term >>= expr) <* symbol ")" else + Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean + +runGadt :: Text -> Either Text Wrapper +runGadt input = + let res = M.runParserT (gadtExpr <* M.eof) "" input + in res >>= first (pack . M.errorBundlePretty) diff --git a/parser-initial/test/Driver.hs b/initial-encoding/test/Driver.hs similarity index 100% rename from parser-initial/test/Driver.hs rename to initial-encoding/test/Driver.hs diff --git a/parser-initial/test/Test/ParserTest.hs b/initial-encoding/test/Test/ParserTest.hs similarity index 69% rename from parser-initial/test/Test/ParserTest.hs rename to initial-encoding/test/Test/ParserTest.hs index 354bdf6..ec4a17a 100644 --- a/parser-initial/test/Test/ParserTest.hs +++ b/initial-encoding/test/Test/ParserTest.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Test.ParserTest @@ -8,18 +9,28 @@ module Test.ParserTest import qualified Text.Megaparsec as M +import Data.Bifunctor (first) +import Data.Functor.Identity (Identity(..)) import Data.Text (Text, pack) import Parser import Test.Hspec (Expectation, Spec, describe, it, shouldBe) -runParser :: Parser Expr -> Text -> IO (Either Text Expr) -runParser m input = pure case M.parse (m <* M.eof) "ParserTest" input of - Left e -> Left . pack $ M.errorBundlePretty e - Right a -> eval a +type Parser = ParserT Identity -runParsers :: Text -> IO [Either Text Expr] -runParsers input = - mapM (`runParser` input) [naiveExpr, mulPassExpr, memConsExpr] +convert :: GExpr a -> Expr +convert (GInt a) = EInt a +convert (GBool a) = EBool a +convert (GAdd lhs rhs) = EAdd (convert lhs) (convert rhs) +convert (GSub lhs rhs) = ESub (convert lhs) (convert rhs) +convert (GAnd lhs rhs) = EAnd (convert lhs) (convert rhs) +convert (GOr lhs rhs) = EOr (convert lhs) (convert rhs) + +runParsers :: Text -> [Either Text Expr] +runParsers input = [runNaive, runMulPass, runMemCons, runGadt'] <*> [input] + where + runGadt' i = do + Wrapper res <- runGadt i + pure $ convert res allEqual :: forall a. Eq a => [a] -> Bool allEqual [] = True @@ -29,13 +40,13 @@ allEqual (x:y:xs) = x == y && allEqual (y : xs) shouldParse :: Text -> Expr -> Expectation shouldParse input expected = do - res@(x : _) <- runParsers input + let res@(x : _) = runParsers input shouldBe x $ Right expected shouldBe True $ allEqual res shouldNotParse :: Text -> Text -> Expectation shouldNotParse input expected = do - res@(x : _) <- runParsers input + let res@(x : _) = runParsers input shouldBe x $ Left expected spec_parser :: Spec diff --git a/parser-initial/app/Main.hs b/parser-initial/app/Main.hs deleted file mode 100644 index 0ca475f..0000000 --- a/parser-initial/app/Main.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import qualified Parser as P -import qualified Text.Megaparsec as M - -import Data.Text (Text) -import Data.Text.IO (hGetContents) -import Options.Applicative -import System.Environment (getArgs) -import System.IO (IOMode(ReadMode), openFile) - -data Args = Args - { argsFileName :: !FilePath - , argsMethod :: !Text - } - -args :: Parser Args -args = Args - <$> strArgument (metavar "FILENAME" <> help "The file we want to parse.") - <*> strOption - ( short 'm' - <> long "method" - <> metavar "METHOD" - <> showDefault - <> value "naive" - <> help "The parse strategy we want to try. Should be one of \ - \\"naive\", \"mul_pass\", or \"mem_cons\"." - ) - -run :: Args -> IO () -run args = do - let method = case argsMethod args of - "naive" -> P.naiveExpr - "mul_pass" -> P.mulPassExpr - "mem_cons" -> P.memConsExpr - _ -> error "Encountered an invalid parsing strategy." - handle <- openFile (argsFileName args) ReadMode - contents <- hGetContents handle - case M.parse (method <* M.eof) (argsFileName args) contents of - Left e -> print $ M.errorBundlePretty e - Right a -> print $ P.eval a - -main :: IO () -main = run =<< execParser opts - where - opts = info (args <**> helper) - ( fullDesc - <> progDesc "Different parsing strategies using initial encoding" - <> header "Initial encoding parsing" - ) diff --git a/parser-initial/src/Parser.hs b/parser-initial/src/Parser.hs deleted file mode 100644 index f684fda..0000000 --- a/parser-initial/src/Parser.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} - -module Parser -( Expr(..) -, Parser -, eval -, memConsExpr -, mulPassExpr -, naiveExpr -) where - -import qualified Control.Monad.Combinators.Expr as E -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as MC -import qualified Text.Megaparsec.Char.Lexer as ML - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..), deepseq) -import Control.Monad.State (MonadState, modify) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Either (hoistEither) -import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Data.Char (isDigit) -import Data.Foldable (foldl') -import Data.Functor (($>), void) -import Data.Maybe (isJust) -import Data.Text (Text, unpack) -import Data.Text.IO (hGetContents) -import Data.Void (Void) -import Numeric (readDec) -import System.Environment (getArgs) -import System.IO (IOMode(ReadMode), openFile) - --- ======================================== --- ADT --- ======================================== - -data Expr - = EInt Integer - | EBool Bool - | EAdd Expr Expr - | ESub Expr Expr - | EAnd Expr Expr - | EOr Expr Expr - deriving (Eq, Show) - -eval :: Expr -> Either Text Expr -eval e@(EInt _) = pure e -eval e@(EBool _) = pure e -eval (EAdd lhs rhs) = do - (lhs', rhs') <- binInt lhs rhs - pure $ EInt (lhs' + rhs') -eval (ESub lhs rhs) = do - (lhs', rhs') <- binInt lhs rhs - pure $ EInt (lhs' - rhs') -eval (EAnd lhs rhs) = do - (lhs', rhs') <- binBool lhs rhs - pure $ EBool (lhs' && rhs') -eval (EOr lhs rhs) = do - (lhs', rhs') <- binBool lhs rhs - pure $ EBool (lhs' || rhs') - -binInt :: Expr -> Expr -> Either Text (Integer, Integer) -binInt lhs rhs = do - lhs' <- eval lhs - rhs' <- eval rhs - case (lhs', rhs') of - (EInt lhs'', EInt rhs'') -> pure (lhs'', rhs'') - _ -> Left "Expected two integers." - -binBool :: Expr -> Expr -> Either Text (Bool, Bool) -binBool lhs rhs = do - lhs' <- eval lhs - rhs' <- eval rhs - case (lhs', rhs') of - (EBool lhs'', EBool rhs'') -> pure (lhs'', rhs'') - _ -> Left "Expected two booleans." - --- ======================================== --- Lexers --- ======================================== - -type Parser = M.Parsec Void Text - -space :: Parser () -space = ML.space MC.space1 M.empty M.empty -{-# INLINE space #-} - -lexeme :: forall a. Parser a -> Parser a -lexeme = ML.lexeme MC.space -{-# INLINE lexeme #-} - -symbol :: Text -> Parser Text -symbol = ML.symbol space -{-# INLINE symbol #-} - -parens :: forall a. Parser a -> Parser a -parens = M.between (symbol "(") (symbol ")") -{-# INLINE parens #-} - -boolean :: Parser Bool -boolean = lexeme $ MC.string "true" $> True <|> MC.string "false" $> False -{-# INLINE boolean #-} - -integer :: Parser Integer -integer = lexeme ML.decimal -{-# INLINE integer #-} - --- ======================================== --- Naive attempt --- ======================================== - -naiveExpr :: Parser Expr -naiveExpr = E.makeExprParser term - [ [binary "+" EAdd, binary "-" ESub] - , [binary "&&" EAnd, binary "||" EOr] - ] - where - binary name f = E.InfixL (f <$ symbol name) - - term = parens naiveExpr <|> - EInt <$> integer <|> - EBool <$> boolean - --- ======================================== --- Multiple passes --- ======================================== - -mulPassExpr :: Parser Expr -mulPassExpr = expr >>= either (fail . unpack) pure - where - expr = E.makeExprParser term - [ [binary "+" binInt EInt EAdd, binary "-" binInt EInt ESub] - , [binary "&&" binBool EBool EAnd, binary "||" binBool EBool EOr] - ] - - binary name b f op = E.InfixL do - void $ symbol name - pure $ \lhs rhs -> do - lhs' <- lhs - rhs' <- rhs - (lhs', rhs') <- b lhs' rhs' - eval $ op (f lhs') (f rhs') - - term = parens expr <|> - Right . EInt <$> integer <|> - Right . EBool <$> boolean - --- ======================================== --- Memory consumption --- ======================================== - -instance NFData Expr where - rnf (EInt e) = rnf e - rnf (EBool e) = rnf e - rnf (EAdd lhs rhs) = rnf lhs `seq` rnf rhs - rnf (ESub lhs rhs) = rnf lhs `seq` rnf rhs - rnf (EAnd lhs rhs) = rnf lhs `seq` rnf rhs - rnf (EOr lhs rhs) = rnf lhs `seq` rnf rhs - -memConsExpr :: Parser Expr -memConsExpr = do - e <- runExceptT $ term >>= expr - either (fail . unpack) pure e - where - expr :: Expr -> ExceptT Text Parser Expr - expr t = do - op <- lift $ M.option Nothing $ Just <$> M.choice - [symbol "+", symbol "-", symbol "&&", symbol "||"] - case op of - Just "+" -> nest t EAdd - Just "-" -> nest t ESub - Just "&&" -> nest t EAnd - Just "||" -> nest t EOr - _ -> pure t - - nest t f = do - t' <- term - z <- hoistEither . eval $ f t t' - -- Need to reduce to NF for strictness guarantees. - z `deepseq` expr z - - term = do - p <- lift $ M.option Nothing $ Just <$> symbol "(" - if isJust p then (term >>= expr) <* lift (symbol ")") else - lift $ EInt <$> integer <|> EBool <$> boolean