1
Fork 0

Add with GADT support.

jrpotter/final
Joshua Potter 2021-12-21 22:28:03 -05:00
parent 7303a43f5b
commit 41926c8abc
8 changed files with 397 additions and 253 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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