diff --git a/cabal.project b/cabal.project index d1e1495..08decdf 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,5 @@ packages: initial-encoding leibniz-proof + parser-utils tagless-final diff --git a/initial-encoding/app/Main.hs b/initial-encoding/app/Main.hs index 2fe310f..3ee8d49 100644 --- a/initial-encoding/app/Main.hs +++ b/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.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 diff --git a/initial-encoding/initial-encoding.cabal b/initial-encoding/initial-encoding.cabal index cca2b54..093f882 100644 --- a/initial-encoding/initial-encoding.cabal +++ b/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 diff --git a/initial-encoding/src/Parser.hs b/initial-encoding/src/Parser/Initial.hs similarity index 81% rename from initial-encoding/src/Parser.hs rename to initial-encoding/src/Parser/Initial.hs index d6a319c..53f7d4b 100644 --- a/initial-encoding/src/Parser.hs +++ b/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.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 -- ======================================== diff --git a/initial-encoding/test/Test/ParserTest.hs b/initial-encoding/test/Test/Parser/InitialTest.hs similarity index 96% rename from initial-encoding/test/Test/ParserTest.hs rename to initial-encoding/test/Test/Parser/InitialTest.hs index ec4a17a..80c990d 100644 --- a/initial-encoding/test/Test/ParserTest.hs +++ b/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 diff --git a/parser-utils/parser-utils.cabal b/parser-utils/parser-utils.cabal new file mode 100644 index 0000000..a1452c9 --- /dev/null +++ b/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 diff --git a/parser-utils/src/Parser/Utils.hs b/parser-utils/src/Parser/Utils.hs new file mode 100644 index 0000000..83ee374 --- /dev/null +++ b/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 + ] diff --git a/tagless-final/app/Main.hs b/tagless-final/app/Main.hs index 6d96a09..293a9fb 100644 --- a/tagless-final/app/Main.hs +++ b/tagless-final/app/Main.hs @@ -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" + ) diff --git a/tagless-final/src/Closed/Parser.hs b/tagless-final/src/Parser/Tagless/Closed.hs similarity index 59% rename from tagless-final/src/Closed/Parser.hs rename to tagless-final/src/Parser/Tagless/Closed.hs index 481a1e6..314a3bd 100644 --- a/tagless-final/src/Closed/Parser.hs +++ b/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 - -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 diff --git a/tagless-final/tagless-final.cabal b/tagless-final/tagless-final.cabal index 6346fdd..e1596e5 100644 --- a/tagless-final/tagless-final.cabal +++ b/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 diff --git a/tagless-final/test/Driver.hs b/tagless-final/test/Driver.hs new file mode 100644 index 0000000..327adf4 --- /dev/null +++ b/tagless-final/test/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/tagless-final/test/Test/Parser/Tagless/ClosedTest.hs b/tagless-final/test/Test/Parser/Tagless/ClosedTest.hs new file mode 100644 index 0000000..1e15915 --- /dev/null +++ b/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"