Add implementations and tests around closed tagless final.

Refactor to share some logic with initial-encoding.

cabal.project

@@ -1,4 +1,5 @@
 packages:
   initial-encoding
   leibniz-proof
+  parser-utils
   tagless-final

initial-encoding/app/Main.hs

@@ -1,23 +1,15 @@
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
-import qualified Text.Megaparsec as M
+import Data.Text (Text)
-
-import Data.Bifunctor (first)
-import Data.Text (Text, pack)
 import Data.Text.IO (hGetContents)
 import Options.Applicative
-import Parser
+import Parser.Initial
 import System.Environment (getArgs)
 import System.IO (IOMode(ReadMode), openFile)
 
-data Args = Args
+data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
-  { argsFileName :: !FilePath
-  , argsMethod :: !Text
-  }
 
 args :: Parser Args
 args = Args

initial-encoding/initial-encoding.cabal

@@ -19,12 +19,13 @@ library
                       megaparsec,
                       mtl,
                       parser-combinators,
+                      parser-utils,
                       text,
                       transformers,
                       transformers-either
   hs-source-dirs:     src
   default-language:   Haskell2010
-  exposed-modules:    Parser
+  exposed-modules:    Parser.Initial
 
 test-suite initial-encoding-test
   type:               exitcode-stdio-1.0
@@ -35,8 +36,9 @@ test-suite initial-encoding-test
                       hspec,
                       initial-encoding,
                       megaparsec,
+                      parser-utils,
                       tasty,
                       tasty-discover,
                       tasty-hspec,
                       text
-  other-modules:      Test.ParserTest
+  other-modules:      Test.Parser.InitialTest

initial-encoding/src/Parser/Initial.hs

@@ -5,17 +5,12 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Parser
+module Parser.Initial
 ( Expr(..)
 , GExpr(..)
-, ParserT
 , Wrapper(..)
 , eval
 , gadtEval
-, gadtExpr
-, memConsExpr
-, mulPassExpr
-, naiveExpr
 , runGadt
 , runMemCons
 , runMulPass
@@ -24,29 +19,16 @@ module Parser
 
 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.Functor (void)
-import Data.Foldable (foldl')
-import Data.Functor (($>), void)
 import Data.Maybe (isJust)
 import Data.Text (Text, pack, unpack)
-import Data.Text.IO (hGetContents)
+import Parser.Utils
-import Data.Void (Void)
-import Numeric (readDec)
-import System.Environment (getArgs)
-import System.IO (IOMode(ReadMode), openFile)
 
 -- ========================================
 -- ADT
@@ -93,46 +75,6 @@ binBool lhs rhs = do
     (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
 -- ========================================

initial-encoding/test/Test/Parser/InitialTest.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Test.ParserTest
+module Test.Parser.InitialTest
 ( spec_parser,
 ) where
 
@@ -12,11 +12,10 @@ import qualified Text.Megaparsec as M
 import Data.Bifunctor (first)
 import Data.Functor.Identity (Identity(..))
 import Data.Text (Text, pack)
-import Parser
+import Parser.Initial
+import Parser.Utils (Parser)
 import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
 
-type Parser = ParserT Identity
-
 convert :: GExpr a -> Expr
 convert (GInt  a) = EInt a
 convert (GBool a) = EBool a

parser-utils/parser-utils.cabal

@@ -0,0 +1,11 @@
+  cabal-version:      3.4
+  name:               parser-utils
+  version:            0.1.0.0
+
+library
+  build-depends:      base ^>=4.14.3.0,
+                      megaparsec,
+                      text
+  hs-source-dirs:     src
+  default-language:   Haskell2010
+  exposed-modules:    Parser.Utils

parser-utils/src/Parser/Utils.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Utils
+( Op(..)
+, Parser
+, ParserT
+, boolean
+, integer
+, lexeme
+, ops
+, parens
+, space
+, symbol
+) where
+
+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 Data.Functor (($>))
+import Data.Text (Text)
+import Data.Void (Void)
+
+type Parser = M.Parsec Void Text
+
+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
+
+instance Show Op where
+  show OpAdd = "+"
+  show OpSub = "-"
+  show OpAnd = "&&"
+  show OpOr  = "||"
+
+ops :: forall m. ParserT m Op
+ops = M.choice
+  [ symbol "+"  $> OpAdd
+  , symbol "-"  $> OpSub
+  , symbol "&&" $> OpAnd
+  , symbol "||" $> OpOr
+  ]

tagless-final/app/Main.hs

@@ -1,21 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Main where
 
-import qualified Text.Megaparsec as M
+import Data.Text (Text)
-
-import Closed.Parser
 import Data.Text.IO (hGetContents)
+import Options.Applicative
+import Parser.Tagless.Closed
 import System.Environment (getArgs)
 import System.IO (IOMode(ReadMode), openFile)
 
--- ========================================
+data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
--- Main
+
--- ========================================
+runExpr :: (Text -> Either Text (Dynamic Eval)) -> Text -> IO ()
+runExpr f input = case f input of
+  Right d -> case fromDyn @Eval @Integer d of
+    Just a -> print a
+    Nothing -> case fromDyn @Eval @Bool d of
+      Just a -> print a
+      Nothing -> print "Could not evaluate expression fully."
+  Left e -> print e
+
+args :: Parser Args
+args = Args
+  <$> strArgument (metavar "FILENAME" <> help "The file we want to parse.")
+  <*> strOption
+     ( short 'm'
+    <> long "method"
+    <> metavar "METHOD"
+    <> showDefault
+    <> value "mul_pass"
+    <> help "The parse strategy we want to try. Should be one of \
+            \\"mul_pass\" or \"mem_cons\"."
+     )
+
+run :: Args -> IO ()
+run args = do
+  handle <- openFile (argsFileName args) ReadMode
+  contents <- hGetContents handle
+  case argsMethod args of
+    "mul_pass" -> runExpr runMulPass contents
+    "mem_cons" -> runExpr runMemCons contents
+    _          -> error "Encountered an invalid parsing strategy."
 
 main :: IO ()
-main = do
+main = run =<< execParser opts
-  [fileName] <- getArgs
+ where
-  handle <- openFile fileName ReadMode
+  opts = info (args <**> helper)
-  contents <- hGetContents handle
+    ( fullDesc
-  case M.parse expr fileName contents of
+   <> progDesc "Different parsing strategies using initial encoding"
-    Left e -> print $ M.errorBundlePretty e
+   <> header "Initial encoding parsing"
-    Right a -> print (fromDyn a :: Maybe (Eval Integer))
+    )

tagless-final/src/Parser/Tagless/Closed.hs

@@ -1,21 +1,24 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 
-module Closed.Parser
+module Parser.Tagless.Closed
 ( Dynamic(..)
 , Eval(..)
-, Parser
 , SQ(..)
 , Symantics(..)
 , TQ(..)
 , Typeable(..)
-, expr
 , fromDyn
+, runMemCons
+, runMulPass
 , toDyn
 ) where
 
@@ -26,10 +29,17 @@ 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 (join)
+import Control.Monad.Except (MonadError, throwError)
+import Data.Bifunctor (first)
 import Data.Eq.Type ((:=))
 import Data.Functor (($>), void)
-import Data.Text (Text, unpack)
+import Data.Functor.Identity (runIdentity)
+import Data.Maybe (isJust)
+import Data.Text (Text, pack, unpack)
 import Data.Void (Void)
+import Parser.Utils
 
 -- ========================================
 -- Symantics
@@ -53,7 +63,7 @@ instance Symantics SQ where
   eAnd (SQ lhs) (SQ rhs) = SQ (eAnd lhs rhs)
   eOr  (SQ lhs) (SQ rhs) = SQ (eOr  lhs rhs)
 
-newtype Eval a = Eval {runEval :: a} deriving Show
+newtype Eval a = Eval {runEval :: a} deriving (Eq, Show)
 
 instance Symantics Eval where
   eInt  = Eval
@@ -120,41 +130,10 @@ fromDyn (Dynamic t e) = case t of
     pure $ EQ.coerce (EQ.lift r') e
 
 -- ========================================
--- Parser code
+-- Multiple passes
 -- ========================================
 
-type Parser = M.Parsec Void Text
+binDyn
-
-space :: Parser ()
-space = ML.space MC.space1 M.empty M.empty
-{-# INLINE space #-}
-
-lexeme_ :: forall a. Parser a -> Parser a
-lexeme_ = ML.lexeme $ MC.space1 <|> M.eof
-{-# 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_ do
-  MC.string "true" $> True <|> MC.string "false" $> False
-{-# INLINE boolean #-}
-
-integer :: Parser Integer
-integer = lexeme_ ML.decimal
-{-# INLINE integer #-}
-
--- ========================================
--- Deserialization
--- ========================================
-
-mkBinary
   :: forall repr a
    . Symantics repr
   => IsDynamic a
@@ -162,28 +141,93 @@ mkBinary
   -> Dynamic repr
   -> Dynamic repr
   -> Maybe (Dynamic repr)
-mkBinary bin lhs rhs = do
+binDyn bin lhs rhs = do
   lhs' <- fromDyn lhs
   rhs' <- fromDyn rhs
   pure . Dynamic type' $ bin lhs' rhs'
 
-expr :: forall repr. Symantics repr => Parser (Dynamic repr)
+mulPassExpr :: forall repr. Symantics repr => Parser (Dynamic repr)
-expr = expr' >>= \case
+mulPassExpr = expr >>= \case
   Left (offset, msg) -> M.setOffset offset >> fail msg
   Right a -> pure a
  where
-  expr' = E.makeExprParser
+  expr = E.makeExprParser term
-    (parens expr' <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean)
+    [ [binary "+" eAdd, binary "-" eSub]
-    [ [binary' "+" eAdd, binary' "-" eSub]
+    , [binary "&&" eAnd, binary "||" eOr]
-    , [binary' "&&" eAnd, binary' "||" eOr]
     ]
 
-  binary' name bin = E.InfixL do
+  binary name bin = E.InfixL do
     void $ symbol name
     offset <- M.getOffset
     pure $ \lhs rhs -> do
       lhs' <- lhs
       rhs' <- rhs
-      case mkBinary bin lhs' rhs' of
+      case binDyn bin lhs' rhs' of
-        Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
+        Nothing -> throwError
+          (offset, "Invalid operands for `" <> unpack name <> "`")
         Just a -> pure a
+
+  term = parens expr <|>
+         Right . toDyn <$> integer <|>
+         Right . toDyn <$> boolean
+
+runMulPass :: forall repr. Symantics repr => Text -> Either Text (Dynamic repr)
+runMulPass input =
+  let res = M.runParser (mulPassExpr <* M.eof) "" input
+   in first (pack . M.errorBundlePretty) res
+
+-- ========================================
+-- Memory consumption
+-- ========================================
+
+instance (NFData t) => NFData (Eval t) where
+  rnf (Eval t) = t `seq` ()
+
+instance NFData (Dynamic Eval) where
+  rnf (Dynamic t e) = e `seq` ()
+
+memConsExpr
+  :: forall repr
+   . Symantics repr
+  => NFData (Dynamic repr)
+  => Parser (Dynamic repr)
+memConsExpr = term >>= expr
+ where
+  expr :: Dynamic repr -> Parser (Dynamic repr)
+  expr t = do
+    op <- M.option Nothing $ Just <$> ops
+    case op of
+      Just OpAdd -> nest t eAdd OpAdd
+      Just OpSub -> nest t eSub OpSub
+      Just OpAnd -> nest t eAnd OpAnd
+      Just OpOr  -> nest t eOr  OpOr
+      _          -> pure t
+
+  nest
+    :: forall a
+     . IsDynamic a
+    => Dynamic repr
+    -> (repr a -> repr a -> repr a)
+    -> Op
+    -> Parser (Dynamic repr)
+  nest t bin op = do
+    t' <- term
+    case binDyn bin t t' of
+      Nothing -> fail $ "Invalid operands for `" <> show op <> "`"
+      Just a -> a `deepseq` expr a
+
+  term :: Parser (Dynamic repr)
+  term = do
+    p <- M.option Nothing $ Just <$> symbol "("
+    if isJust p then (term >>= expr) <* symbol ")" else
+      toDyn <$> integer <|> toDyn <$> boolean
+
+runMemCons
+  :: forall repr
+   . Symantics repr
+  => NFData (Dynamic repr)
+  => Text
+  -> Either Text (Dynamic repr)
+runMemCons input =
+  let res = M.runParser (memConsExpr <* M.eof) "" input
+   in first (pack . M.errorBundlePretty) res

tagless-final/tagless-final.cabal

@@ -6,6 +6,7 @@ executable tagless-final
   main-is:          Main.hs
   build-depends:    base ^>=4.14.3.0,
                     megaparsec,
+                    optparse-applicative,
                     tagless-final,
                     text
   hs-source-dirs:   app
@@ -13,10 +14,29 @@ executable tagless-final
 
 library
   build-depends:      base ^>=4.14.3.0,
+                      deepseq,
                       eq,
                       megaparsec,
+                      mtl,
                       parser-combinators,
+                      parser-utils,
                       text
   hs-source-dirs:     src
   default-language:   Haskell2010
-  exposed-modules:    Closed.Parser
+  exposed-modules:    Parser.Tagless.Closed
+
+test-suite tagless-final-test
+  type:               exitcode-stdio-1.0
+  main-is:            Driver.hs
+  hs-source-dirs:     test
+  build-depends:      base ^>=4.14.3.0,
+                      HUnit,
+                      hspec,
+                      megaparsec,
+                      parser-utils,
+                      tagless-final,
+                      tasty,
+                      tasty-discover,
+                      tasty-hspec,
+                      text
+  other-modules:      Test.Parser.Tagless.ClosedTest

tagless-final/test/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}

tagless-final/test/Test/Parser/Tagless/ClosedTest.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Parser.Tagless.ClosedTest
+( spec_parser,
+) where
+
+import Data.Text (Text)
+import Parser.Tagless.Closed
+import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
+
+runParsers :: Text -> [Either Text (Dynamic Eval)]
+runParsers input = [runMulPass, runMemCons] <*> [input]
+
+instance Eq (Dynamic Eval) where
+  d1 == d2 = case (fromDyn @Eval @Integer d1, fromDyn @Eval @Integer d2) of
+    (Just a1, Just a2) -> a1 == a2
+    _ -> case (fromDyn @Eval @Bool d1, fromDyn @Eval @Bool d2) of
+      (Just a1, Just a2) -> a1 == a2
+      _ -> False
+
+instance Show (Dynamic Eval) where
+  show d = case fromDyn @Eval @Integer d of
+    Just a -> show a
+    _ -> case fromDyn @Eval @Bool d of
+      Just a -> show a
+      _ -> error "No valid `Eval` instance."
+
+allEqual :: forall a. Eq a => [a] -> Bool
+allEqual [] = True
+allEqual [x] = True
+allEqual [x, y] = x == y
+allEqual (x:y:xs) = x == y && allEqual (y : xs)
+
+shouldParse :: Text -> Dynamic Eval -> Expectation
+shouldParse input expected = do
+  let res@(x : _) = runParsers input
+  shouldBe x $ Right expected
+  shouldBe True $ allEqual res
+
+shouldNotParse :: Text -> Text -> Expectation
+shouldNotParse input expected = do
+  let res@(x : _) = runParsers input
+  shouldBe x $ Left expected
+
+spec_parser :: Spec
+spec_parser = do
+  describe "literals" do
+    it "1" do
+      shouldParse "1" (toDyn @Eval @Integer 1)
+    it "true" do
+      shouldParse "true" (toDyn True)
+    it "false" do
+      shouldParse "false" (toDyn False)
+  describe "addition/subtraction" do
+    it "binary" do
+      shouldParse "1 + 1" (toDyn @Eval @Integer 2)
+    it "left associative" do
+      shouldParse "1 - 3 + 4" (toDyn @Eval @Integer 2)
+    it "precedence" do
+      shouldParse "1 - (3 + 4)" (toDyn @Eval @Integer (-6))
+  describe "conjunction/disjunction" do
+    it "binary" do
+      shouldParse "true && false" (toDyn False)
+      shouldParse "true && true" (toDyn True)
+      shouldParse "true || true" (toDyn True)
+      shouldParse "true || false" (toDyn True)
+      shouldParse "false || false" (toDyn False)
+  describe "invalid types" do
+    it "mismatch" do
+      shouldNotParse "true && 1"
+        "1:9:\n  |\n1 | true && 1\n  |         ^\nInvalid operands for `&&`\n"
+      shouldNotParse "1 + true"
+        "1:5:\n  |\n1 | 1 + true\n  |     ^\nInvalid operands for `+`\n"