1
Fork 0

Add implementations and tests around closed tagless final.

Refactor to share some logic with initial-encoding.
jrpotter/final
Joshua Potter 2021-12-23 08:21:05 -05:00
parent c7abf209eb
commit cef32ad12b
12 changed files with 329 additions and 140 deletions

View File

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

View File

@ -1,23 +1,15 @@
{-# 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 (Text)
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
{ argsFileName :: !FilePath
, argsMethod :: !Text
}
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
args :: Parser Args
args = Args

View File

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

View File

@ -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.Foldable (foldl')
import Data.Functor (($>), void)
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)
import Parser.Utils
-- ========================================
-- 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
-- ========================================

View File

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

View File

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

View File

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

View File

@ -1,21 +1,53 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import qualified Text.Megaparsec as M
import Closed.Parser
import Data.Text (Text)
import Data.Text.IO (hGetContents)
import Options.Applicative
import Parser.Tagless.Closed
import System.Environment (getArgs)
import System.IO (IOMode(ReadMode), openFile)
-- ========================================
-- Main
-- ========================================
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
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
[fileName] <- getArgs
handle <- openFile fileName ReadMode
contents <- hGetContents handle
case M.parse expr fileName contents of
Left e -> print $ M.errorBundlePretty e
Right a -> print (fromDyn a :: Maybe (Eval Integer))
main = run =<< execParser opts
where
opts = info (args <**> helper)
( fullDesc
<> progDesc "Different parsing strategies using initial encoding"
<> header "Initial encoding parsing"
)

View File

@ -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
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
binDyn
:: 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)
expr = expr' >>= \case
mulPassExpr :: forall repr. Symantics repr => Parser (Dynamic repr)
mulPassExpr = expr >>= \case
Left (offset, msg) -> M.setOffset offset >> fail msg
Right a -> pure a
where
expr' = E.makeExprParser
(parens expr' <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean)
[ [binary' "+" eAdd, binary' "-" eSub]
, [binary' "&&" eAnd, binary' "||" eOr]
expr = E.makeExprParser term
[ [binary "+" eAdd, binary "-" eSub]
, [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
Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
case binDyn bin lhs' rhs' of
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

View File

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

View File

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

View File

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