Cleanup parser-initial code.
parent
c69f000ebe
commit
a63f2688db
|
@ -1,5 +1,4 @@
|
||||||
packages:
|
packages:
|
||||||
leibniz-proof
|
leibniz-proof
|
||||||
parser-adt
|
|
||||||
parser-closed
|
parser-closed
|
||||||
parser-gadt
|
parser-initial
|
||||||
|
|
13
flake.nix
13
flake.nix
|
@ -10,11 +10,22 @@
|
||||||
flake-utils.lib.eachDefaultSystem (system:
|
flake-utils.lib.eachDefaultSystem (system:
|
||||||
let
|
let
|
||||||
pkgs = nixpkgs.legacyPackages.${system};
|
pkgs = nixpkgs.legacyPackages.${system};
|
||||||
|
ghc = pkgs.haskellPackages.ghc;
|
||||||
|
hls = pkgs.haskell-language-server.override {
|
||||||
|
supportedGhcVersions = [ "8107" ];
|
||||||
|
};
|
||||||
in {
|
in {
|
||||||
devShell = pkgs.mkShell {
|
devShell = pkgs.mkShell {
|
||||||
buildInputs = [
|
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.cabal-install
|
||||||
pkgs.haskellPackages.ghc
|
pkgs.haskellPackages.tasty-discover
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
});
|
});
|
||||||
|
|
|
@ -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
|
|
|
@ -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
|
|
|
@ -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"
|
||||||
|
)
|
|
@ -1,9 +1,18 @@
|
||||||
cabal-version: 3.4
|
cabal-version: 3.4
|
||||||
name: parser-adt
|
name: parser-initial
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
|
||||||
executable parser-adt
|
executable parser-initial
|
||||||
main-is: Main.hs
|
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,
|
build-depends: base ^>=4.14.3.0,
|
||||||
deepseq,
|
deepseq,
|
||||||
megaparsec,
|
megaparsec,
|
||||||
|
@ -12,5 +21,6 @@ executable parser-adt
|
||||||
text,
|
text,
|
||||||
transformers,
|
transformers,
|
||||||
transformers-either
|
transformers-either
|
||||||
hs-source-dirs: app
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
exposed-modules: Parser
|
|
@ -1,10 +1,13 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Main where
|
module Parser
|
||||||
|
( eval
|
||||||
|
, memConsExpr
|
||||||
|
, mulPassExpr
|
||||||
|
, naiveExpr
|
||||||
|
) where
|
||||||
|
|
||||||
import qualified Control.Monad.Combinators.Expr as E
|
import qualified Control.Monad.Combinators.Expr as E
|
||||||
import qualified Text.Megaparsec as M
|
import qualified Text.Megaparsec as M
|
||||||
|
@ -178,23 +181,6 @@ memConsExpr = do
|
||||||
z `deepseq` expr z
|
z `deepseq` expr z
|
||||||
|
|
||||||
term = do
|
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
|
if isJust p then (term >>= expr) <* lift (symbol ")") else
|
||||||
lift $ EInt <$> integer <|> EBool <$> boolean
|
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
|
|
Loading…
Reference in New Issue