From a63f2688db0c53501409f9762b70449fff70272b Mon Sep 17 00:00:00 2001 From: Joshua Potter Date: Mon, 20 Dec 2021 08:53:18 -0500 Subject: [PATCH] Cleanup parser-initial code. --- cabal.project | 3 +- flake.nix | 13 +- hie.yaml | 2 + parser-gadt/app/Main.hs | 116 ------------------ parser-gadt/parser-gadt.cabal | 12 -- parser-initial/app/Main.hs | 52 ++++++++ .../parser-initial.cabal | 16 ++- .../Main.hs => parser-initial/src/Parser.hs | 28 ++--- 8 files changed, 87 insertions(+), 155 deletions(-) create mode 100644 hie.yaml delete mode 100644 parser-gadt/app/Main.hs delete mode 100644 parser-gadt/parser-gadt.cabal create mode 100644 parser-initial/app/Main.hs rename parser-adt/parser-adt.cabal => parser-initial/parser-initial.cabal (55%) rename parser-adt/app/Main.hs => parser-initial/src/Parser.hs (89%) diff --git a/cabal.project b/cabal.project index 0d89d56..f34a4ea 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,4 @@ packages: leibniz-proof - parser-adt parser-closed - parser-gadt + parser-initial diff --git a/flake.nix b/flake.nix index e76d1b5..6d3c220 100644 --- a/flake.nix +++ b/flake.nix @@ -10,11 +10,22 @@ flake-utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system}; + ghc = pkgs.haskellPackages.ghc; + hls = pkgs.haskell-language-server.override { + supportedGhcVersions = [ "8107" ]; + }; in { devShell = pkgs.mkShell { buildInputs = [ + ghc + hls + pkgs.gdb + # GHC depends on LANG so need this package to properly interpret our + # files with e.g. tasty-discover. + # https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/ + pkgs.glibcLocales pkgs.haskellPackages.cabal-install - pkgs.haskellPackages.ghc + pkgs.haskellPackages.tasty-discover ]; }; }); diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..04cd243 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/parser-gadt/app/Main.hs b/parser-gadt/app/Main.hs deleted file mode 100644 index c597627..0000000 --- a/parser-gadt/app/Main.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Main 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 Data.Char (isDigit) -import Data.Foldable (foldl') -import Data.Functor (($>)) -import Data.Text (Text) -import Data.Void (Void) -import Numeric (readDec) -import System.Environment (getArgs) - --- ======================================== --- GADT --- ======================================== - -data Expr a where - EInt :: Integer -> Expr Integer - EBool :: Bool -> Expr Bool - EAdd :: Expr Integer -> Expr Integer -> Expr Integer - ESub :: Expr Integer -> Expr Integer -> Expr Integer - EAnd :: Expr Bool -> Expr Bool -> Expr Bool - EOr :: Expr Bool -> Expr Bool -> Expr Bool - -deriving instance Show (Expr Integer) -deriving instance Show (Expr Bool) - -eval :: forall a. Expr a -> Either Bool Integer -eval (EInt e) = Right e -eval (EBool e) = Left e -eval (EAdd lhs rhs) = - let Right r1 = eval lhs - Right r2 = eval rhs - in Right (r1 + r2) -eval (ESub lhs rhs) = - let Right r1 = eval lhs - Right r2 = eval rhs - in Right (r1 - r2) -eval (EAnd lhs rhs) = - let Left r1 = eval lhs - Left r2 = eval rhs - in Left (r1 && r2) -eval (EOr lhs rhs) = - let Left r1 = eval lhs - Left r2 = eval rhs - in Left (r1 || r2) - --- ======================================== --- Unused parser code --- ======================================== - -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_ do - i <- M.some $ M.satisfy isDigit - case readDec i of - [(value, "")] -> pure value - _ -> fail "integer" -{-# INLINE integer #-} - -{- -Couldn't match type `Bool` with `Integer` - -parseExpr = E.makeExprParser parseTerm - [ [binary "+" EAdd, binary "-" ESub] - , [binary "&&" EAnd, binary "||" EOr] - ] - where - binary name f = E.InfixL (f <$ symbol name) - parseTerm = parens parseExpr <|> - EInt <$> integer <|> - EBool <$> boolean --} - --- ======================================== --- Main --- ======================================== - -main :: IO () -main = do - [count] <- map read <$> getArgs - let expr = foldl' EAdd (EInt 0) $ take count (EInt <$> [1..]) - print $ {-# SCC "evaluated" #-} eval expr diff --git a/parser-gadt/parser-gadt.cabal b/parser-gadt/parser-gadt.cabal deleted file mode 100644 index 9c81aed..0000000 --- a/parser-gadt/parser-gadt.cabal +++ /dev/null @@ -1,12 +0,0 @@ - cabal-version: 3.4 - name: parser-gadt - version: 0.1.0.0 - -executable parser-gadt - main-is: Main.hs - build-depends: base ^>=4.14.3.0, - megaparsec, - parser-combinators, - text - hs-source-dirs: app - default-language: Haskell2010 diff --git a/parser-initial/app/Main.hs b/parser-initial/app/Main.hs new file mode 100644 index 0000000..0ca475f --- /dev/null +++ b/parser-initial/app/Main.hs @@ -0,0 +1,52 @@ +{-# 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" + ) diff --git a/parser-adt/parser-adt.cabal b/parser-initial/parser-initial.cabal similarity index 55% rename from parser-adt/parser-adt.cabal rename to parser-initial/parser-initial.cabal index 3d4ea9c..b8bcc97 100644 --- a/parser-adt/parser-adt.cabal +++ b/parser-initial/parser-initial.cabal @@ -1,9 +1,18 @@ cabal-version: 3.4 - name: parser-adt + name: parser-initial version: 0.1.0.0 -executable parser-adt +executable parser-initial main-is: Main.hs + build-depends: base ^>=4.14.3.0, + megaparsec, + optparse-applicative, + parser-initial, + text, + hs-source-dirs: app + default-language: Haskell2010 + +library build-depends: base ^>=4.14.3.0, deepseq, megaparsec, @@ -12,5 +21,6 @@ executable parser-adt text, transformers, transformers-either - hs-source-dirs: app + hs-source-dirs: src default-language: Haskell2010 + exposed-modules: Parser diff --git a/parser-adt/app/Main.hs b/parser-initial/src/Parser.hs similarity index 89% rename from parser-adt/app/Main.hs rename to parser-initial/src/Parser.hs index 9b11541..7cddf56 100644 --- a/parser-adt/app/Main.hs +++ b/parser-initial/src/Parser.hs @@ -1,10 +1,13 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Main where +module Parser +( eval +, memConsExpr +, mulPassExpr +, naiveExpr +) where import qualified Control.Monad.Combinators.Expr as E import qualified Text.Megaparsec as M @@ -178,23 +181,6 @@ memConsExpr = do z `deepseq` expr z term = do - p <- lift $ M.option Nothing $ Just <$> (symbol "(") + p <- lift $ M.option Nothing $ Just <$> symbol "(" if isJust p then (term >>= expr) <* lift (symbol ")") else lift $ EInt <$> integer <|> EBool <$> boolean - --- ======================================== --- Main --- ======================================== - -run :: FilePath -> IO () -run fileName = do - handle <- openFile fileName ReadMode - contents <- hGetContents handle - case M.parse (memConsExpr <* M.eof) fileName contents of - Left e -> print $ M.errorBundlePretty e - Right a -> print $ eval a - -main :: IO () -main = do - [fileName] <- getArgs - run fileName