Add with GADT support.

cabal.project

@@ -1,4 +1,4 @@
 packages:
+  initial-encoding
   leibniz-proof
   parser-closed
-  parser-initial

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"
+    )

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,

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)

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)
+type Parser = ParserT Identity
-runParser m input = pure case M.parse (m <* M.eof) "ParserTest" input of
-  Left e -> Left . pack $ M.errorBundlePretty e
-  Right a -> eval a
 
-runParsers :: Text -> IO [Either Text Expr]
+convert :: GExpr a -> Expr
-runParsers input =
+convert (GInt  a) = EInt a
-  mapM (`runParser` input) [naiveExpr, mulPassExpr, memConsExpr]
+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

parser-initial/app/Main.hs

@@ -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"
-      )

parser-initial/src/Parser.hs

@@ -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