Add implementations and tests around closed tagless final.
Refactor to share some logic with initial-encoding.jrpotter/final
parent
c7abf209eb
commit
cef32ad12b
|
@ -1,4 +1,5 @@
|
||||||
packages:
|
packages:
|
||||||
initial-encoding
|
initial-encoding
|
||||||
leibniz-proof
|
leibniz-proof
|
||||||
|
parser-utils
|
||||||
tagless-final
|
tagless-final
|
||||||
|
|
|
@ -1,23 +1,15 @@
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Text.Megaparsec as M
|
import Data.Text (Text)
|
||||||
|
|
||||||
import Data.Bifunctor (first)
|
|
||||||
import Data.Text (Text, pack)
|
|
||||||
import Data.Text.IO (hGetContents)
|
import Data.Text.IO (hGetContents)
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import Parser
|
import Parser.Initial
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.IO (IOMode(ReadMode), openFile)
|
import System.IO (IOMode(ReadMode), openFile)
|
||||||
|
|
||||||
data Args = Args
|
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
||||||
{ argsFileName :: !FilePath
|
|
||||||
, argsMethod :: !Text
|
|
||||||
}
|
|
||||||
|
|
||||||
args :: Parser Args
|
args :: Parser Args
|
||||||
args = Args
|
args = Args
|
||||||
|
|
|
@ -19,12 +19,13 @@ library
|
||||||
megaparsec,
|
megaparsec,
|
||||||
mtl,
|
mtl,
|
||||||
parser-combinators,
|
parser-combinators,
|
||||||
|
parser-utils,
|
||||||
text,
|
text,
|
||||||
transformers,
|
transformers,
|
||||||
transformers-either
|
transformers-either
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
exposed-modules: Parser
|
exposed-modules: Parser.Initial
|
||||||
|
|
||||||
test-suite initial-encoding-test
|
test-suite initial-encoding-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
|
@ -35,8 +36,9 @@ test-suite initial-encoding-test
|
||||||
hspec,
|
hspec,
|
||||||
initial-encoding,
|
initial-encoding,
|
||||||
megaparsec,
|
megaparsec,
|
||||||
|
parser-utils,
|
||||||
tasty,
|
tasty,
|
||||||
tasty-discover,
|
tasty-discover,
|
||||||
tasty-hspec,
|
tasty-hspec,
|
||||||
text
|
text
|
||||||
other-modules: Test.ParserTest
|
other-modules: Test.Parser.InitialTest
|
||||||
|
|
|
@ -5,17 +5,12 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Parser
|
module Parser.Initial
|
||||||
( Expr(..)
|
( Expr(..)
|
||||||
, GExpr(..)
|
, GExpr(..)
|
||||||
, ParserT
|
|
||||||
, Wrapper(..)
|
, Wrapper(..)
|
||||||
, eval
|
, eval
|
||||||
, gadtEval
|
, gadtEval
|
||||||
, gadtExpr
|
|
||||||
, memConsExpr
|
|
||||||
, mulPassExpr
|
|
||||||
, naiveExpr
|
|
||||||
, runGadt
|
, runGadt
|
||||||
, runMemCons
|
, runMemCons
|
||||||
, runMulPass
|
, runMulPass
|
||||||
|
@ -24,29 +19,16 @@ module Parser
|
||||||
|
|
||||||
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
|
||||||
import qualified Text.Megaparsec.Char as MC
|
|
||||||
import qualified Text.Megaparsec.Char.Lexer as ML
|
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.Applicative.Combinators (skipMany)
|
|
||||||
import Control.DeepSeq (NFData(..), deepseq)
|
import Control.DeepSeq (NFData(..), deepseq)
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
import Control.Monad.Except (MonadError, throwError)
|
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.Bifunctor (bimap, first)
|
||||||
import Data.Char (isDigit)
|
import Data.Functor (void)
|
||||||
import Data.Foldable (foldl')
|
|
||||||
import Data.Functor (($>), void)
|
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe (isJust)
|
||||||
import Data.Text (Text, pack, unpack)
|
import Data.Text (Text, pack, unpack)
|
||||||
import Data.Text.IO (hGetContents)
|
import Parser.Utils
|
||||||
import Data.Void (Void)
|
|
||||||
import Numeric (readDec)
|
|
||||||
import System.Environment (getArgs)
|
|
||||||
import System.IO (IOMode(ReadMode), openFile)
|
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- ADT
|
-- ADT
|
||||||
|
@ -93,46 +75,6 @@ binBool lhs rhs = do
|
||||||
(EBool lhs'', EBool rhs'') -> pure (lhs'', rhs'')
|
(EBool lhs'', EBool rhs'') -> pure (lhs'', rhs'')
|
||||||
_ -> Left "Expected two booleans."
|
_ -> 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
|
-- Naive attempt
|
||||||
-- ========================================
|
-- ========================================
|
|
@ -3,7 +3,7 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Test.ParserTest
|
module Test.Parser.InitialTest
|
||||||
( spec_parser,
|
( spec_parser,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -12,11 +12,10 @@ import qualified Text.Megaparsec as M
|
||||||
import Data.Bifunctor (first)
|
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
|
import Parser.Initial
|
||||||
|
import Parser.Utils (Parser)
|
||||||
import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
||||||
|
|
||||||
type Parser = ParserT Identity
|
|
||||||
|
|
||||||
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
|
|
@ -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
|
|
@ -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
|
||||||
|
]
|
|
@ -1,21 +1,53 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Text.Megaparsec as M
|
import Data.Text (Text)
|
||||||
|
|
||||||
import Closed.Parser
|
|
||||||
import Data.Text.IO (hGetContents)
|
import Data.Text.IO (hGetContents)
|
||||||
|
import Options.Applicative
|
||||||
|
import Parser.Tagless.Closed
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.IO (IOMode(ReadMode), openFile)
|
import System.IO (IOMode(ReadMode), openFile)
|
||||||
|
|
||||||
-- ========================================
|
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
||||||
-- Main
|
|
||||||
-- ========================================
|
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 :: IO ()
|
||||||
main = do
|
main = run =<< execParser opts
|
||||||
[fileName] <- getArgs
|
where
|
||||||
handle <- openFile fileName ReadMode
|
opts = info (args <**> helper)
|
||||||
contents <- hGetContents handle
|
( fullDesc
|
||||||
case M.parse expr fileName contents of
|
<> progDesc "Different parsing strategies using initial encoding"
|
||||||
Left e -> print $ M.errorBundlePretty e
|
<> header "Initial encoding parsing"
|
||||||
Right a -> print (fromDyn a :: Maybe (Eval Integer))
|
)
|
||||||
|
|
|
@ -1,21 +1,24 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
module Closed.Parser
|
module Parser.Tagless.Closed
|
||||||
( Dynamic(..)
|
( Dynamic(..)
|
||||||
, Eval(..)
|
, Eval(..)
|
||||||
, Parser
|
|
||||||
, SQ(..)
|
, SQ(..)
|
||||||
, Symantics(..)
|
, Symantics(..)
|
||||||
, TQ(..)
|
, TQ(..)
|
||||||
, Typeable(..)
|
, Typeable(..)
|
||||||
, expr
|
|
||||||
, fromDyn
|
, fromDyn
|
||||||
|
, runMemCons
|
||||||
|
, runMulPass
|
||||||
, toDyn
|
, toDyn
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -26,10 +29,17 @@ import qualified Text.Megaparsec.Char as MC
|
||||||
import qualified Text.Megaparsec.Char.Lexer as ML
|
import qualified Text.Megaparsec.Char.Lexer as ML
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
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.Eq.Type ((:=))
|
||||||
import Data.Functor (($>), void)
|
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 Data.Void (Void)
|
||||||
|
import Parser.Utils
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Symantics
|
-- Symantics
|
||||||
|
@ -53,7 +63,7 @@ instance Symantics SQ where
|
||||||
eAnd (SQ lhs) (SQ rhs) = SQ (eAnd lhs rhs)
|
eAnd (SQ lhs) (SQ rhs) = SQ (eAnd lhs rhs)
|
||||||
eOr (SQ lhs) (SQ rhs) = SQ (eOr 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
|
instance Symantics Eval where
|
||||||
eInt = Eval
|
eInt = Eval
|
||||||
|
@ -120,41 +130,10 @@ fromDyn (Dynamic t e) = case t of
|
||||||
pure $ EQ.coerce (EQ.lift r') e
|
pure $ EQ.coerce (EQ.lift r') e
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Parser code
|
-- Multiple passes
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
type Parser = M.Parsec Void Text
|
binDyn
|
||||||
|
|
||||||
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
|
|
||||||
:: forall repr a
|
:: forall repr a
|
||||||
. Symantics repr
|
. Symantics repr
|
||||||
=> IsDynamic a
|
=> IsDynamic a
|
||||||
|
@ -162,28 +141,93 @@ mkBinary
|
||||||
-> Dynamic repr
|
-> Dynamic repr
|
||||||
-> Dynamic repr
|
-> Dynamic repr
|
||||||
-> Maybe (Dynamic repr)
|
-> Maybe (Dynamic repr)
|
||||||
mkBinary bin lhs rhs = do
|
binDyn bin lhs rhs = do
|
||||||
lhs' <- fromDyn lhs
|
lhs' <- fromDyn lhs
|
||||||
rhs' <- fromDyn rhs
|
rhs' <- fromDyn rhs
|
||||||
pure . Dynamic type' $ bin lhs' rhs'
|
pure . Dynamic type' $ bin lhs' rhs'
|
||||||
|
|
||||||
expr :: forall repr. Symantics repr => Parser (Dynamic repr)
|
mulPassExpr :: forall repr. Symantics repr => Parser (Dynamic repr)
|
||||||
expr = expr' >>= \case
|
mulPassExpr = 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
|
||||||
expr' = E.makeExprParser
|
expr = E.makeExprParser term
|
||||||
(parens expr' <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean)
|
[ [binary "+" eAdd, binary "-" eSub]
|
||||||
[ [binary' "+" eAdd, binary' "-" eSub]
|
, [binary "&&" eAnd, binary "||" eOr]
|
||||||
, [binary' "&&" eAnd, binary' "||" eOr]
|
|
||||||
]
|
]
|
||||||
|
|
||||||
binary' name bin = E.InfixL do
|
binary name bin = E.InfixL do
|
||||||
void $ symbol name
|
void $ symbol name
|
||||||
offset <- M.getOffset
|
offset <- M.getOffset
|
||||||
pure $ \lhs rhs -> do
|
pure $ \lhs rhs -> do
|
||||||
lhs' <- lhs
|
lhs' <- lhs
|
||||||
rhs' <- rhs
|
rhs' <- rhs
|
||||||
case mkBinary bin lhs' rhs' of
|
case binDyn bin lhs' rhs' of
|
||||||
Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
|
Nothing -> throwError
|
||||||
|
(offset, "Invalid operands for `" <> unpack name <> "`")
|
||||||
Just a -> pure a
|
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
|
|
@ -6,6 +6,7 @@ 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,
|
||||||
tagless-final,
|
tagless-final,
|
||||||
text
|
text
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
|
@ -13,10 +14,29 @@ executable tagless-final
|
||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base ^>=4.14.3.0,
|
build-depends: base ^>=4.14.3.0,
|
||||||
|
deepseq,
|
||||||
eq,
|
eq,
|
||||||
megaparsec,
|
megaparsec,
|
||||||
|
mtl,
|
||||||
parser-combinators,
|
parser-combinators,
|
||||||
|
parser-utils,
|
||||||
text
|
text
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
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
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
|
|
@ -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"
|
Loading…
Reference in New Issue