blog
/
tagless-final-parsing
1
Fork 0
Code

Minor clean up of final implementation. 

Convert initial encoding with better `Result`.
main
Joshua Potter 2021-12-24 08:16:06 -05:00
parent cef32ad12b
commit 6f1e8de814
9 changed files with 319 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
initial-encoding/app/Main.hs
View File

@ -2,52 +2,62 @@
module Main where module Main where
import qualified Options.Applicative as O
import qualified Text.Megaparsec as M
import Data.Text (Text) import Data.Text (Text)
import Data.Text.IO (hGetContents) import Data.Text.IO (hGetContents)
import Options.Applicative import Options.Applicative ((<**>))
import Parser.Initial import Parser.Initial
import Parser.Utils
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (IOMode(ReadMode), openFile) import System.IO (IOMode(ReadMode), openFile)
-- ========================================
-- Arguments
-- ========================================
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text} data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
args :: Parser Args args :: O.Parser Args
args = Args args = Args
<$> strArgument (metavar "FILENAME" <> help "The file we want to parse.") <$> O.strArgument
<*> strOption ( O.metavar "FILENAME" <> O.help "The file we want to parse."
( short 'm' )
<> long "method" <*> O.strOption
<> metavar "METHOD" ( O.short 'm'
<> showDefault <> O.long "method"
<> value "naive" <> O.metavar "METHOD"
<> help "The parse strategy we want to try. Should be one of \ <> O.showDefault
\\"naive\", \"mul_pass\", or \"mem_cons\"." <> O.value "naive"
) <> O.help "The parse strategy we want to try. Should be one of 'naive', \
\'single', 'strict', or 'gadt'."
)
runExpr :: (Text -> Either Text Expr) -> Text -> IO () -- ========================================
runExpr f input = case f input >>= eval of -- Main
Right (EInt e) -> print e -- ========================================
Right (EBool e) -> print e
_ -> error "Could not evaluate expression fully."
run :: Args -> IO () run :: Args -> IO ()
run args = do run args = do
handle <- openFile (argsFileName args) ReadMode handle <- openFile (argsFileName args) ReadMode
contents <- hGetContents handle input <- hGetContents handle
case argsMethod args of case argsMethod args of
"naive" -> runExpr runNaive contents "naive" -> runExpr parseNaive input
"mul_pass" -> runExpr runMulPass contents "single" -> runExpr parseSingle input
"mem_cons" -> runExpr runMemCons contents "strict" -> runExpr parseStrict input
"gadt" -> case runGadt contents of "gadt" -> case runParser parseGadt input of
Left e -> print e Left e -> print e
Right (Wrapper a) -> print $ gadtEval a Right (Wrapper a) -> print $ eval a
_ -> error "Encountered an invalid parsing strategy." _ -> error "Encountered an invalid parsing strategy."
where
runExpr p input = either print print (runParser p input)
main :: IO () main :: IO ()
main = run =<< execParser opts main = run =<< O.execParser opts
where where
opts = info (args <**> helper) opts = O.info (args <**> O.helper)
( fullDesc ( O.fullDesc
<> progDesc "Different parsing strategies using initial encoding" <> O.progDesc "Different parsing strategies using initial encoding"
<> header "Initial encoding parsing" <> O.header "Initial encoding parsing"
) )

1
initial-encoding/initial-encoding.cabal
View File

@ -9,6 +9,7 @@ executable initial-encoding
megaparsec, megaparsec,
mtl, mtl,
optparse-applicative, optparse-applicative,
parser-utils,
text, text,
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010

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

@ -8,13 +8,14 @@
module Parser.Initial module Parser.Initial
( Expr(..) ( Expr(..)
, GExpr(..) , GExpr(..)
, Result(..)
, Wrapper(..) , Wrapper(..)
, eval , eval
, gadtEval , parseGadt
, runGadt , parseNaive
, runMemCons , parseSingle
, runMulPass , parseStrict
, runNaive , toResult
) where ) where
import qualified Control.Monad.Combinators.Expr as E import qualified Control.Monad.Combinators.Expr as E
@ -43,132 +44,112 @@ data Expr
| EOr Expr Expr | EOr Expr Expr
deriving (Eq, Show) deriving (Eq, Show)
eval :: Expr -> Either Text Expr data Result = RInt Integer | RBool Bool deriving (Eq)
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) instance Show Result where
binInt lhs rhs = do show (RInt e) = show e
lhs' <- eval lhs show (RBool e) = show e
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) asInt :: Result -> Either Text Integer
binBool lhs rhs = do asInt (RInt e) = pure e
lhs' <- eval lhs asInt _ = Left "Could not cast integer."
rhs' <- eval rhs
case (lhs', rhs') of asBool :: Result -> Either Text Bool
(EBool lhs'', EBool rhs'') -> pure (lhs'', rhs'') asBool (RBool e) = pure e
_ -> Left "Expected two booleans." asBool _ = Left "Could not cast boolean."
toResult :: Expr -> Either Text Result
toResult (EInt e) = pure $ RInt e
toResult (EBool e) = pure $ RBool e
toResult (EAdd lhs rhs) = do
lhs' <- toResult lhs >>= asInt
rhs' <- toResult rhs >>= asInt
pure $ RInt (lhs' + rhs')
toResult (ESub lhs rhs) = do
lhs' <- toResult lhs >>= asInt
rhs' <- toResult rhs >>= asInt
pure $ RInt (lhs' - rhs')
toResult (EAnd lhs rhs) = do
lhs' <- toResult lhs >>= asBool
rhs' <- toResult rhs >>= asBool
pure $ RBool (lhs' && rhs')
toResult (EOr lhs rhs) = do
lhs' <- toResult lhs >>= asBool
rhs' <- toResult rhs >>= asBool
pure $ RBool (lhs' || rhs')
-- ======================================== -- ========================================
-- Naive attempt -- Naive attempt
-- ======================================== -- ========================================
naiveExpr :: forall m. ParserT m Expr parseNaive :: Parser Result
naiveExpr = E.makeExprParser term parseNaive = expr >>= either (fail . unpack) pure . toResult
[ [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 where
expr = E.makeExprParser term expr = E.makeExprParser term
[ [ binary "+" binInt EInt EAdd [ [binary "+" EAdd, binary "-" ESub]
, binary "-" binInt EInt ESub , [binary "&&" EAnd, binary "||" EOr]
] ]
, [ binary "&&" binBool EBool EAnd
, binary "||" binBool EBool EOr binary name f = E.InfixL (f <$ symbol name)
]
term = parens expr <|> EInt <$> integer <|> EBool <$> boolean
-- ========================================
-- Single pass
-- ========================================
parseSingle :: Parser Result
parseSingle = expr >>= either (fail . unpack) pure
where
expr = E.makeExprParser term
[ [binary "+" asInt EInt EAdd, binary "-" asInt EInt ESub]
, [binary "&&" asBool EBool EAnd, binary "||" asBool EBool EOr ]
] ]
binary name cast f bin = E.InfixL do binary name cast f bin = E.InfixL do
void $ symbol name void $ symbol name
pure $ \lhs rhs -> do pure $ \lhs rhs -> do
lhs' <- lhs lhs' <- lhs >>= cast
rhs' <- rhs rhs' <- rhs >>= cast
(lhs', rhs') <- cast lhs' rhs' toResult $ bin (f lhs') (f rhs')
eval $ bin (f lhs') (f rhs')
term = parens expr <|> term = parens expr <|> Right . RInt <$> integer <|> Right . RBool <$> boolean
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 -- Strict
-- ======================================== -- ========================================
instance NFData Expr where parseStrict :: Parser Result
rnf (EInt e) = rnf e parseStrict = term >>= expr
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 where
expr t = do expr t = do
op <- M.option Nothing $ Just <$> ops op <- M.option Nothing $ Just <$> ops
case op of case op of
Just OpAdd -> nest t EAdd Just OpAdd -> nest t asInt EInt EAdd
Just OpSub -> nest t ESub Just OpSub -> nest t asInt EInt ESub
Just OpAnd -> nest t EAnd Just OpAnd -> nest t asBool EBool EAnd
Just OpOr -> nest t EOr Just OpOr -> nest t asBool EBool EOr
_ -> pure t _ -> pure t
nest :: Expr -> (Expr -> Expr -> Expr) -> ParserT m Expr nest
nest t bin = do :: forall a
. Result
-> (Result -> Either Text a)
-> (a -> Expr)
-> (Expr -> Expr -> Expr)
-> Parser Result
nest t cast f bin = do
t' <- term t' <- term
case eval (bin t t') of a <- either (fail . unpack) pure do
Left e -> throwError e lhs <- cast t
Right a -> a `deepseq` expr a rhs <- cast t'
toResult $ bin (f lhs) (f rhs)
a `seq` expr a
term = do term = do
p <- M.option Nothing $ Just <$> symbol "(" p <- M.option Nothing $ Just <$> symbol "("
if isJust p then (term >>= expr) <* symbol ")" else if isJust p then (term >>= expr) <* symbol ")" else
EInt <$> integer <|> EBool <$> boolean RInt <$> integer <|> RBool <$> 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 -- GADTs
@ -176,52 +157,44 @@ runMemCons input =
data GExpr a where data GExpr a where
GInt :: Integer -> GExpr Integer GInt :: Integer -> GExpr Integer
GBool :: Bool -> GExpr Bool GBool :: Bool -> GExpr Bool
GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer
GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer
GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool
GOr :: 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) data Wrapper = forall a. Show a => Wrapper (GExpr a)
fromInt :: GExpr a -> Either Text (GExpr Integer) eval :: GExpr a -> a
fromInt a@(GInt _ ) = pure a eval (GInt a) = a
fromInt a@(GAdd _ _) = pure a eval (GBool a) = a
fromInt a@(GSub _ _) = pure a eval (GAdd lhs rhs) = eval lhs + eval rhs
fromInt _ = Left "Expected an integer type." eval (GSub lhs rhs) = eval lhs - eval rhs
eval (GAnd lhs rhs) = eval lhs && eval rhs
eval (GOr lhs rhs) = eval lhs || eval rhs
fromBool :: GExpr a -> Either Text (GExpr Bool) asInt' :: GExpr a -> Either Text (GExpr Integer)
fromBool a@(GBool _ ) = pure a asInt' a@(GInt _ ) = pure a
fromBool a@(GAnd _ _) = pure a asInt' a@(GAdd _ _) = pure a
fromBool a@(GOr _ _) = pure a asInt' a@(GSub _ _) = pure a
fromBool _ = Left "Expected a boolean type." asInt' _ = Left "Expected an integer type."
gadtEval :: GExpr a -> a asBool' :: GExpr a -> Either Text (GExpr Bool)
gadtEval (GInt a) = a asBool' a@(GBool _ ) = pure a
gadtEval (GBool a) = a asBool' a@(GAnd _ _) = pure a
gadtEval (GAdd lhs rhs) = gadtEval lhs + gadtEval rhs asBool' a@(GOr _ _) = pure a
gadtEval (GSub lhs rhs) = gadtEval lhs - gadtEval rhs asBool' _ = Left "Expected a boolean type."
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 parseGadt :: Parser Wrapper
gadtExpr = term >>= expr parseGadt = term >>= expr
where where
expr t = do expr t = do
op <- M.option Nothing $ Just <$> ops op <- M.option Nothing $ Just <$> ops
case op of case op of
Just OpAdd -> nest t fromInt GAdd GInt Just OpAdd -> nest t asInt' GInt GAdd
Just OpSub -> nest t fromInt GSub GInt Just OpSub -> nest t asInt' GInt GSub
Just OpAnd -> nest t fromBool GAnd GBool Just OpAnd -> nest t asBool' GBool GAnd
Just OpOr -> nest t fromBool GOr GBool Just OpOr -> nest t asBool' GBool GOr
_ -> pure t _ -> pure t
nest nest
@ -229,24 +202,19 @@ gadtExpr = term >>= expr
. Show b . Show b
=> Wrapper => Wrapper
-> (forall a. GExpr a -> Either Text (GExpr b)) -> (forall a. GExpr a -> Either Text (GExpr b))
-> (GExpr b -> GExpr b -> GExpr b)
-> (b -> GExpr b) -> (b -> GExpr b)
-> ParserT m Wrapper -> (GExpr b -> GExpr b -> GExpr b)
nest (Wrapper t) cast bin f = do -> Parser Wrapper
nest (Wrapper t) cast f bin = do
Wrapper t' <- term Wrapper t' <- term
case (cast t, cast t') of case (cast t, cast t') of
(Right lhs, Right rhs) -> do (Right lhs, Right rhs) -> do
let z = f . gadtEval $ bin lhs rhs let z = eval $ bin lhs rhs
z `deepseq` expr (Wrapper z) z `seq` expr (Wrapper $ f z)
(Left e, _) -> throwError e (Left e, _) -> fail $ unpack e
(_, Left e) -> throwError e (_, Left e) -> fail $ unpack e
term = do term = do
p <- M.option Nothing $ Just <$> symbol "(" p <- M.option Nothing $ Just <$> symbol "("
if isJust p then (term >>= expr) <* symbol ")" else if isJust p then (term >>= expr) <* symbol ")" else
Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean 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)

63
initial-encoding/test/Test/Parser/InitialTest.hs
View File

@ -13,9 +13,13 @@ import Data.Bifunctor (first)
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Parser.Initial import Parser.Initial
import Parser.Utils (Parser) import Parser.Utils (Parser, allEqual, runParser)
import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
-- ========================================
-- Utility
-- ========================================
convert :: GExpr a -> Expr convert :: GExpr a -> Expr
convert (GInt a) = EInt a convert (GInt a) = EInt a
convert (GBool a) = EBool a convert (GBool a) = EBool a
@ -24,20 +28,23 @@ convert (GSub lhs rhs) = ESub (convert lhs) (convert rhs)
convert (GAnd lhs rhs) = EAnd (convert lhs) (convert rhs) convert (GAnd lhs rhs) = EAnd (convert lhs) (convert rhs)
convert (GOr lhs rhs) = EOr (convert lhs) (convert rhs) convert (GOr lhs rhs) = EOr (convert lhs) (convert rhs)
runParsers :: Text -> [Either Text Expr] runParsers :: Text -> [Either Text Result]
runParsers input = [runNaive, runMulPass, runMemCons, runGadt'] <*> [input] runParsers input =
[ runParser parseNaive
, runParser parseSingle
, runParser parseStrict
, runGadt
] <*> [input]
where where
runGadt' i = do runGadt i = do
Wrapper res <- runGadt i Wrapper res <- runParser parseGadt i
pure $ convert res toResult $ convert res
allEqual :: forall a. Eq a => [a] -> Bool -- ========================================
allEqual [] = True -- Assertions
allEqual [x] = True -- ========================================
allEqual [x, y] = x == y
allEqual (x:y:xs) = x == y && allEqual (y : xs)
shouldParse :: Text -> Expr -> Expectation shouldParse :: Text -> Result -> Expectation
shouldParse input expected = do shouldParse input expected = do
let res@(x : _) = runParsers input let res@(x : _) = runParsers input
shouldBe x $ Right expected shouldBe x $ Right expected
@ -48,30 +55,36 @@ shouldNotParse input expected = do
let res@(x : _) = runParsers input let res@(x : _) = runParsers input
shouldBe x $ Left expected shouldBe x $ Left expected
-- ========================================
-- Tests
-- ========================================
spec_parser :: Spec spec_parser :: Spec
spec_parser = do spec_parser = do
describe "literals" do describe "literals" do
it "1" do it "1" do
shouldParse "1" (EInt 1) shouldParse "1" (RInt 1)
it "true" do it "true" do
shouldParse "true" (EBool True) shouldParse "true" (RBool True)
it "false" do it "false" do
shouldParse "false" (EBool False) shouldParse "false" (RBool False)
describe "addition/subtraction" do describe "addition/subtraction" do
it "binary" do it "binary" do
shouldParse "1 + 1" (EInt 2) shouldParse "1 + 1" (RInt 2)
it "left associative" do it "left associative" do
shouldParse "1 - 3 + 4" (EInt 2) shouldParse "1 - 3 + 4" (RInt 2)
it "precedence" do it "precedence" do
shouldParse "1 - (3 + 4)" (EInt (-6)) shouldParse "1 - (3 + 4)" (RInt (-6))
describe "conjunction/disjunction" do describe "conjunction/disjunction" do
it "binary" do it "binary" do
shouldParse "true && false" (EBool False) shouldParse "true && false" (RBool False)
shouldParse "true && true" (EBool True) shouldParse "true && true" (RBool True)
shouldParse "true || true" (EBool True) shouldParse "true || true" (RBool True)
shouldParse "true || false" (EBool True) shouldParse "true || false" (RBool True)
shouldParse "false || false" (EBool False) shouldParse "false || false" (RBool False)
describe "invalid types" do describe "invalid types" do
it "mismatch" do it "mismatch" do
shouldNotParse "true && 1" "Expected two booleans." shouldNotParse "true && 1"
shouldNotParse "1 + true" "Expected two integers." "1:10:\n |\n1 | true && 1\n | ^\nCould not cast boolean.\n"
shouldNotParse "1 + true"
"1:9:\n |\n1 | 1 + true\n | ^\nCould not cast integer.\n"

23
parser-utils/src/Parser/Utils.hs
View File

@ -5,11 +5,13 @@ module Parser.Utils
( Op(..) ( Op(..)
, Parser , Parser
, ParserT , ParserT
, allEqual
, boolean , boolean
, integer , integer
, lexeme , lexeme
, ops , ops
, parens , parens
, runParser
, space , space
, symbol , symbol
) where ) where
@ -20,9 +22,13 @@ import qualified Text.Megaparsec.Char.Lexer as ML
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Text (Text) import Data.Text (Text, pack)
import Data.Void (Void) import Data.Void (Void)
-- ========================================
-- Parsing
-- ========================================
type Parser = M.Parsec Void Text type Parser = M.Parsec Void Text
type ParserT = M.ParsecT Void Text type ParserT = M.ParsecT Void Text
@ -66,3 +72,18 @@ ops = M.choice
, symbol "&&" $> OpAnd , symbol "&&" $> OpAnd
, symbol "||" $> OpOr , symbol "||" $> OpOr
] ]
runParser :: forall a. Parser a -> Text -> Either Text a
runParser p input = case M.runParser (p <* M.eof) "" input of
Left e -> Left . pack $ M.errorBundlePretty e
Right a -> pure a
-- ========================================
-- Utility
-- ========================================
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)

63
tagless-final/app/Main.hs
View File

@ -3,51 +3,64 @@
module Main where module Main where
import qualified Options.Applicative as O
import Data.Text (Text) import Data.Text (Text)
import Data.Text.IO (hGetContents) import Data.Text.IO (hGetContents)
import Options.Applicative import Options.Applicative ((<**>))
import Parser.Tagless.Closed import Parser.Final
import Parser.Utils
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (IOMode(ReadMode), openFile) import System.IO (IOMode(ReadMode), openFile)
-- ========================================
-- Arguments
-- ========================================
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text} data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
runExpr :: (Text -> Either Text (Dynamic Eval)) -> Text -> IO () args :: O.Parser Args
runExpr f input = case f input of args = Args
<$> O.strArgument
( O.metavar "FILENAME" <> O.help "The file we want to parse."
)
<*> O.strOption
( O.short 'm'
<> O.long "method"
<> O.metavar "METHOD"
<> O.showDefault
<> O.value "single"
<> O.help "The parse strategy we want to try. Should be one of 'single' \
\or 'strict'."
)
-- ========================================
-- Main
-- ========================================
runExpr :: Parser (Dynamic Eval) -> Text -> IO ()
runExpr p input = case runParser p input of
Left e -> print e
Right d -> case fromDyn @Eval @Integer d of Right d -> case fromDyn @Eval @Integer d of
Just a -> print a Just a -> print a
Nothing -> case fromDyn @Eval @Bool d of Nothing -> case fromDyn @Eval @Bool d of
Just a -> print a Just a -> print a
Nothing -> print "Could not evaluate expression fully." 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 -> IO ()
run args = do run args = do
handle <- openFile (argsFileName args) ReadMode handle <- openFile (argsFileName args) ReadMode
contents <- hGetContents handle contents <- hGetContents handle
case argsMethod args of case argsMethod args of
"mul_pass" -> runExpr runMulPass contents "single" -> runExpr parseSingle contents
"mem_cons" -> runExpr runMemCons contents "strict" -> runExpr parseStrict contents
_ -> error "Encountered an invalid parsing strategy." _ -> error "Encountered an invalid parsing strategy."
main :: IO () main :: IO ()
main = run =<< execParser opts main = run =<< O.execParser opts
where where
opts = info (args <**> helper) opts = O.info (args <**> O.helper)
( fullDesc ( O.fullDesc
<> progDesc "Different parsing strategies using initial encoding" <> O.progDesc "Different parsing strategies using initial encoding"
<> header "Initial encoding parsing" <> O.header "Initial encoding parsing"
) )

81
tagless-final/src/Parser/Tagless/Closed.hs → tagless-final/src/Parser/Final.hs
View File

@ -9,7 +9,7 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Parser.Tagless.Closed module Parser.Final
( Dynamic(..) ( Dynamic(..)
, Eval(..) , Eval(..)
, SQ(..) , SQ(..)
@ -17,28 +17,21 @@ module Parser.Tagless.Closed
, TQ(..) , TQ(..)
, Typeable(..) , Typeable(..)
, fromDyn , fromDyn
, runMemCons , parseSingle
, runMulPass , parseStrict
, toDyn , toDyn
) where ) where
import qualified Control.Monad.Combinators.Expr as E import qualified Control.Monad.Combinators.Expr as E
import qualified Data.Eq.Type as EQ import qualified Data.Eq.Type as EQ
import qualified Text.Megaparsec as M 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 ((<|>))
import Control.DeepSeq (NFData(..), deepseq) 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.Eq.Type ((:=))
import Data.Functor (($>), void) import Data.Functor (void)
import Data.Functor.Identity (runIdentity)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import Data.Void (Void)
import Parser.Utils import Parser.Utils
-- ======================================== -- ========================================
@ -53,16 +46,6 @@ class Symantics repr where
eAnd :: repr Bool -> repr Bool -> repr Bool eAnd :: repr Bool -> repr Bool -> repr Bool
eOr :: repr Bool -> repr Bool -> repr Bool eOr :: repr Bool -> repr Bool -> repr Bool
newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
instance Symantics SQ where
eInt e = SQ (eInt e)
eBool e = SQ (eBool e)
eAdd (SQ lhs) (SQ rhs) = SQ (eAdd lhs rhs)
eSub (SQ lhs) (SQ rhs) = SQ (eSub lhs rhs)
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 (Eq, Show) newtype Eval a = Eval {runEval :: a} deriving (Eq, Show)
instance Symantics Eval where instance Symantics Eval where
@ -130,7 +113,7 @@ fromDyn (Dynamic t e) = case t of
pure $ EQ.coerce (EQ.lift r') e pure $ EQ.coerce (EQ.lift r') e
-- ======================================== -- ========================================
-- Multiple passes -- Single pass
-- ======================================== -- ========================================
binDyn binDyn
@ -146,8 +129,8 @@ binDyn bin lhs rhs = do
rhs' <- fromDyn rhs rhs' <- fromDyn rhs
pure . Dynamic type' $ bin lhs' rhs' pure . Dynamic type' $ bin lhs' rhs'
mulPassExpr :: forall repr. Symantics repr => Parser (Dynamic repr) parseSingle :: forall repr. Symantics repr => Parser (Dynamic repr)
mulPassExpr = expr >>= \case parseSingle = expr >>= \case
Left (offset, msg) -> M.setOffset offset >> fail msg Left (offset, msg) -> M.setOffset offset >> fail msg
Right a -> pure a Right a -> pure a
where where
@ -163,21 +146,15 @@ mulPassExpr = expr >>= \case
lhs' <- lhs lhs' <- lhs
rhs' <- rhs rhs' <- rhs
case binDyn bin lhs' rhs' of case binDyn bin lhs' rhs' of
Nothing -> throwError Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
(offset, "Invalid operands for `" <> unpack name <> "`")
Just a -> pure a Just a -> pure a
term = parens expr <|> term = parens expr <|>
Right . toDyn <$> integer <|> Right . toDyn <$> integer <|>
Right . toDyn <$> boolean 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 -- Strict
-- ======================================== -- ========================================
instance (NFData t) => NFData (Eval t) where instance (NFData t) => NFData (Eval t) where
@ -186,12 +163,12 @@ instance (NFData t) => NFData (Eval t) where
instance NFData (Dynamic Eval) where instance NFData (Dynamic Eval) where
rnf (Dynamic t e) = e `seq` () rnf (Dynamic t e) = e `seq` ()
memConsExpr parseStrict
:: forall repr :: forall repr
. Symantics repr . Symantics repr
=> NFData (Dynamic repr) => NFData (Dynamic repr)
=> Parser (Dynamic repr) => Parser (Dynamic repr)
memConsExpr = term >>= expr parseStrict = term >>= expr
where where
expr :: Dynamic repr -> Parser (Dynamic repr) expr :: Dynamic repr -> Parser (Dynamic repr)
expr t = do expr t = do
@ -222,12 +199,30 @@ memConsExpr = term >>= expr
if isJust p then (term >>= expr) <* symbol ")" else if isJust p then (term >>= expr) <* symbol ")" else
toDyn <$> integer <|> toDyn <$> boolean toDyn <$> integer <|> toDyn <$> boolean
runMemCons -- ========================================
:: forall repr -- Printer
. Symantics repr -- ========================================
=> NFData (Dynamic repr)
=> Text newtype Print a = Print {runPrint :: Text} deriving (Eq, Show)
-> Either Text (Dynamic repr)
runMemCons input = instance Symantics Print where
let res = M.runParser (memConsExpr <* M.eof) "" input eInt = Print . pack . show
in first (pack . M.errorBundlePretty) res eBool = Print . pack . show
eAdd (Print lhs) (Print rhs) = Print ("(" <> lhs <> " + " <> rhs <> ")")
eSub (Print lhs) (Print rhs) = Print ("(" <> lhs <> " - " <> rhs <> ")")
eAnd (Print lhs) (Print rhs) = Print ("(" <> lhs <> " && " <> rhs <> ")")
eOr (Print lhs) (Print rhs) = Print ("(" <> lhs <> " || " <> rhs <> ")")
-- ========================================
-- Closed
-- ========================================
newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
instance Symantics SQ where
eInt e = SQ (eInt e)
eBool e = SQ (eBool e)
eAdd (SQ lhs) (SQ rhs) = SQ (eAdd lhs rhs)
eSub (SQ lhs) (SQ rhs) = SQ (eSub lhs rhs)
eAnd (SQ lhs) (SQ rhs) = SQ (eAnd lhs rhs)
eOr (SQ lhs) (SQ rhs) = SQ (eOr lhs rhs)

21
tagless-final/tagless-final.cabal
View File

@ -3,14 +3,15 @@
version: 0.1.0.0 version: 0.1.0.0
executable tagless-final executable tagless-final
main-is: Main.hs main-is: Main.hs
build-depends: base ^>=4.14.3.0, build-depends: base ^>=4.14.3.0,
megaparsec, megaparsec,
optparse-applicative, optparse-applicative,
tagless-final, parser-utils,
text tagless-final,
hs-source-dirs: app text
default-language: Haskell2010 hs-source-dirs: app
default-language: Haskell2010
library library
build-depends: base ^>=4.14.3.0, build-depends: base ^>=4.14.3.0,
@ -23,7 +24,7 @@ library
text text
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
exposed-modules: Parser.Tagless.Closed exposed-modules: Parser.Final
test-suite tagless-final-test test-suite tagless-final-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
@ -39,4 +40,4 @@ test-suite tagless-final-test
tasty-discover, tasty-discover,
tasty-hspec, tasty-hspec,
text text
other-modules: Test.Parser.Tagless.ClosedTest other-modules: Test.Parser.FinalTest

25
tagless-final/test/Test/Parser/Tagless/ClosedTest.hs → tagless-final/test/Test/Parser/FinalTest.hs
View File

@ -4,16 +4,18 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Test.Parser.Tagless.ClosedTest module Test.Parser.FinalTest
( spec_parser, ( spec_parser,
) where ) where
import Data.Text (Text) import Data.Text (Text)
import Parser.Tagless.Closed import Parser.Final
import Parser.Utils
import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
runParsers :: Text -> [Either Text (Dynamic Eval)] -- ========================================
runParsers input = [runMulPass, runMemCons] <*> [input] -- Utility
-- ========================================
instance Eq (Dynamic Eval) where instance Eq (Dynamic Eval) where
d1 == d2 = case (fromDyn @Eval @Integer d1, fromDyn @Eval @Integer d2) of d1 == d2 = case (fromDyn @Eval @Integer d1, fromDyn @Eval @Integer d2) of
@ -29,11 +31,12 @@ instance Show (Dynamic Eval) where
Just a -> show a Just a -> show a
_ -> error "No valid `Eval` instance." _ -> error "No valid `Eval` instance."
allEqual :: forall a. Eq a => [a] -> Bool runParsers :: Text -> [Either Text (Dynamic Eval)]
allEqual [] = True runParsers input = [runParser parseSingle, runParser parseStrict] <*> [input]
allEqual [x] = True
allEqual [x, y] = x == y -- ========================================
allEqual (x:y:xs) = x == y && allEqual (y : xs) -- Assertions
-- ========================================
shouldParse :: Text -> Dynamic Eval -> Expectation shouldParse :: Text -> Dynamic Eval -> Expectation
shouldParse input expected = do shouldParse input expected = do
@ -46,6 +49,10 @@ shouldNotParse input expected = do
let res@(x : _) = runParsers input let res@(x : _) = runParsers input
shouldBe x $ Left expected shouldBe x $ Left expected
-- ========================================
-- Tests
-- ========================================
spec_parser :: Spec spec_parser :: Spec
spec_parser = do spec_parser = do
describe "literals" do describe "literals" do