Automatic formatting.
parent
e67d2d8903
commit
caac19270e
|
@ -0,0 +1,13 @@
|
||||||
|
#!/bin/bash
|
||||||
|
set -e
|
||||||
|
|
||||||
|
filesToFormat=$(
|
||||||
|
git --no-pager diff --name-status --no-color --cached | \
|
||||||
|
awk '$1 != "D" && $2 ~ /\.hs/ {print $NF}'
|
||||||
|
)
|
||||||
|
|
||||||
|
for path in $filesToFormat
|
||||||
|
do
|
||||||
|
ormolu --mode inplace $path
|
||||||
|
git add $path
|
||||||
|
done;
|
|
@ -34,3 +34,11 @@ $ direnv allow
|
||||||
|
|
||||||
from the root directory, `nix develop` will be automatically invoked each time
|
from the root directory, `nix develop` will be automatically invoked each time
|
||||||
a change is detected in `flake.nix` or you return to the directory.
|
a change is detected in `flake.nix` or you return to the directory.
|
||||||
|
|
||||||
|
## Formatting
|
||||||
|
|
||||||
|
Link in `.githooks` by running:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
$ git config --local core.hooksPath .githooks/
|
||||||
|
```
|
||||||
|
|
|
@ -25,6 +25,7 @@
|
||||||
# https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/
|
# https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/
|
||||||
pkgs.glibcLocales
|
pkgs.glibcLocales
|
||||||
pkgs.haskellPackages.cabal-install
|
pkgs.haskellPackages.cabal-install
|
||||||
|
pkgs.haskellPackages.ormolu
|
||||||
pkgs.haskellPackages.tasty-discover
|
pkgs.haskellPackages.tasty-discover
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
|
|
|
@ -2,16 +2,15 @@
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Options.Applicative as O
|
|
||||||
import qualified Text.Megaparsec as M
|
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.IO (hGetContents)
|
import Data.Text.IO (hGetContents)
|
||||||
import Options.Applicative ((<**>))
|
import Options.Applicative ((<**>))
|
||||||
|
import qualified Options.Applicative as O
|
||||||
import Parser.Initial
|
import Parser.Initial
|
||||||
import Parser.Utils
|
import Parser.Utils
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.IO (IOMode(ReadMode), openFile)
|
import System.IO (IOMode (ReadMode), openFile)
|
||||||
|
import qualified Text.Megaparsec as M
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Arguments
|
-- Arguments
|
||||||
|
@ -20,18 +19,20 @@ import System.IO (IOMode(ReadMode), openFile)
|
||||||
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
||||||
|
|
||||||
args :: O.Parser Args
|
args :: O.Parser Args
|
||||||
args = Args
|
args =
|
||||||
<$> O.strArgument
|
Args
|
||||||
|
<$> O.strArgument
|
||||||
( O.metavar "FILENAME" <> O.help "The file we want to parse."
|
( O.metavar "FILENAME" <> O.help "The file we want to parse."
|
||||||
)
|
)
|
||||||
<*> O.strOption
|
<*> O.strOption
|
||||||
( O.short 'm'
|
( O.short 'm'
|
||||||
<> O.long "method"
|
<> O.long "method"
|
||||||
<> O.metavar "METHOD"
|
<> O.metavar "METHOD"
|
||||||
<> O.showDefault
|
<> O.showDefault
|
||||||
<> O.value "naive"
|
<> O.value "naive"
|
||||||
<> O.help "The parse strategy we want to try. Should be one of 'naive', \
|
<> O.help
|
||||||
\'single', 'strict', or 'gadt'."
|
"The parse strategy we want to try. Should be one of 'naive', \
|
||||||
|
\'single', 'strict', or 'gadt'."
|
||||||
)
|
)
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
@ -43,21 +44,23 @@ run args = do
|
||||||
handle <- openFile (argsFileName args) ReadMode
|
handle <- openFile (argsFileName args) ReadMode
|
||||||
input <- hGetContents handle
|
input <- hGetContents handle
|
||||||
case argsMethod args of
|
case argsMethod args of
|
||||||
"naive" -> runExpr parseNaive input
|
"naive" -> runExpr parseNaive input
|
||||||
"single" -> runExpr parseSingle input
|
"single" -> runExpr parseSingle input
|
||||||
"strict" -> runExpr parseStrict input
|
"strict" -> runExpr parseStrict input
|
||||||
"gadt" -> case runParser parseGadt input of
|
"gadt" -> case runParser parseGadt input of
|
||||||
Left e -> print e
|
Left e -> print e
|
||||||
Right (Wrapper a) -> print $ eval a
|
Right (Wrapper a) -> print $ eval a
|
||||||
_ -> error "Encountered an invalid parsing strategy."
|
_ -> error "Encountered an invalid parsing strategy."
|
||||||
where
|
where
|
||||||
runExpr p input = either print print (runParser p input)
|
runExpr p input = either print print (runParser p input)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = run =<< O.execParser opts
|
main = run =<< O.execParser opts
|
||||||
where
|
where
|
||||||
opts = O.info (args <**> O.helper)
|
opts =
|
||||||
( O.fullDesc
|
O.info
|
||||||
<> O.progDesc "Different parsing strategies using initial encoding"
|
(args <**> O.helper)
|
||||||
<> O.header "Initial encoding parsing"
|
( O.fullDesc
|
||||||
)
|
<> O.progDesc "Different parsing strategies using initial encoding"
|
||||||
|
<> O.header "Initial encoding parsing"
|
||||||
|
)
|
||||||
|
|
|
@ -6,48 +6,48 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Parser.Initial
|
module Parser.Initial
|
||||||
( Expr(..)
|
( Expr (..),
|
||||||
, GExpr(..)
|
GExpr (..),
|
||||||
, Result(..)
|
Result (..),
|
||||||
, Wrapper(..)
|
Wrapper (..),
|
||||||
, eval
|
eval,
|
||||||
, parseGadt
|
parseGadt,
|
||||||
, parseNaive
|
parseNaive,
|
||||||
, parseSingle
|
parseSingle,
|
||||||
, parseStrict
|
parseStrict,
|
||||||
, toResult
|
toResult,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import qualified Control.Monad.Combinators.Expr as E
|
|
||||||
import qualified Text.Megaparsec as M
|
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.DeepSeq (NFData(..), deepseq)
|
import Control.DeepSeq (NFData (..), deepseq)
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
|
import qualified Control.Monad.Combinators.Expr as E
|
||||||
import Control.Monad.Except (MonadError, throwError)
|
import Control.Monad.Except (MonadError, throwError)
|
||||||
import Data.Bifunctor (bimap, first)
|
import Data.Bifunctor (bimap, first)
|
||||||
import Data.Functor (void)
|
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 Parser.Utils
|
import Parser.Utils
|
||||||
|
import qualified Text.Megaparsec as M
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- ADT
|
-- ADT
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
data Expr
|
data Expr
|
||||||
= EInt Integer
|
= EInt Integer
|
||||||
| EBool Bool
|
| EBool Bool
|
||||||
| EAdd Expr Expr
|
| EAdd Expr Expr
|
||||||
| ESub Expr Expr
|
| ESub Expr Expr
|
||||||
| EAnd Expr Expr
|
| EAnd Expr Expr
|
||||||
| EOr Expr Expr
|
| EOr Expr Expr
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data Result = RInt Integer | RBool Bool deriving (Eq)
|
data Result = RInt Integer | RBool Bool deriving (Eq)
|
||||||
|
|
||||||
instance Show Result where
|
instance Show Result where
|
||||||
show (RInt e) = show e
|
show (RInt e) = show e
|
||||||
show (RBool e) = show e
|
show (RBool e) = show e
|
||||||
|
|
||||||
asInt :: Result -> Either Text Integer
|
asInt :: Result -> Either Text Integer
|
||||||
|
@ -59,7 +59,7 @@ asBool (RBool e) = pure e
|
||||||
asBool _ = Left "Could not cast boolean."
|
asBool _ = Left "Could not cast boolean."
|
||||||
|
|
||||||
toResult :: Expr -> Either Text Result
|
toResult :: Expr -> Either Text Result
|
||||||
toResult (EInt e) = pure $ RInt e
|
toResult (EInt e) = pure $ RInt e
|
||||||
toResult (EBool e) = pure $ RBool e
|
toResult (EBool e) = pure $ RBool e
|
||||||
toResult (EAdd lhs rhs) = do
|
toResult (EAdd lhs rhs) = do
|
||||||
lhs' <- toResult lhs >>= asInt
|
lhs' <- toResult lhs >>= asInt
|
||||||
|
@ -84,15 +84,17 @@ toResult (EOr lhs rhs) = do
|
||||||
|
|
||||||
parseNaive :: Parser Result
|
parseNaive :: Parser Result
|
||||||
parseNaive = expr >>= either (fail . unpack) pure . toResult
|
parseNaive = expr >>= either (fail . unpack) pure . toResult
|
||||||
where
|
where
|
||||||
expr = E.makeExprParser term
|
expr =
|
||||||
[ [binary "+" EAdd, binary "-" ESub]
|
E.makeExprParser
|
||||||
, [binary "&&" EAnd, binary "||" EOr]
|
term
|
||||||
]
|
[ [binary "+" EAdd, binary "-" ESub],
|
||||||
|
[binary "&&" EAnd, binary "||" EOr]
|
||||||
|
]
|
||||||
|
|
||||||
binary name f = E.InfixL (f <$ symbol name)
|
binary name f = E.InfixL (f <$ symbol name)
|
||||||
|
|
||||||
term = parens expr <|> EInt <$> integer <|> EBool <$> boolean
|
term = parens expr <|> EInt <$> integer <|> EBool <$> boolean
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Single pass
|
-- Single pass
|
||||||
|
@ -100,20 +102,22 @@ parseNaive = expr >>= either (fail . unpack) pure . toResult
|
||||||
|
|
||||||
parseSingle :: Parser Result
|
parseSingle :: Parser Result
|
||||||
parseSingle = expr >>= either (fail . unpack) pure
|
parseSingle = expr >>= either (fail . unpack) pure
|
||||||
where
|
where
|
||||||
expr = E.makeExprParser term
|
expr =
|
||||||
[ [binary "+" asInt EInt EAdd, binary "-" asInt EInt ESub]
|
E.makeExprParser
|
||||||
, [binary "&&" asBool EBool EAnd, binary "||" asBool EBool EOr ]
|
term
|
||||||
]
|
[ [binary "+" asInt EInt EAdd, binary "-" asInt EInt ESub],
|
||||||
|
[binary "&&" asBool EBool EAnd, binary "||" asBool EBool EOr]
|
||||||
|
]
|
||||||
|
|
||||||
binary name cast f bin = E.InfixL do
|
binary name cast f bin = E.InfixL do
|
||||||
void $ symbol name
|
void $ symbol name
|
||||||
pure $ \lhs rhs -> do
|
pure $ \lhs rhs -> do
|
||||||
lhs' <- lhs >>= cast
|
lhs' <- lhs >>= cast
|
||||||
rhs' <- rhs >>= cast
|
rhs' <- rhs >>= cast
|
||||||
toResult $ bin (f lhs') (f rhs')
|
toResult $ bin (f lhs') (f rhs')
|
||||||
|
|
||||||
term = parens expr <|> Right . RInt <$> integer <|> Right . RBool <$> boolean
|
term = parens expr <|> Right . RInt <$> integer <|> Right . RBool <$> boolean
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Strict
|
-- Strict
|
||||||
|
@ -125,100 +129,102 @@ instance NFData Result where
|
||||||
|
|
||||||
parseStrict :: Parser Result
|
parseStrict :: Parser Result
|
||||||
parseStrict = term >>= expr
|
parseStrict = term >>= expr
|
||||||
where
|
where
|
||||||
expr t = do
|
expr t = do
|
||||||
op <- M.option Nothing $ Just <$> ops
|
op <- M.option Nothing $ Just <$> ops
|
||||||
case op of
|
case op of
|
||||||
Just OpAdd -> nest t asInt EInt EAdd
|
Just OpAdd -> nest t asInt EInt EAdd
|
||||||
Just OpSub -> nest t asInt EInt ESub
|
Just OpSub -> nest t asInt EInt ESub
|
||||||
Just OpAnd -> nest t asBool EBool EAnd
|
Just OpAnd -> nest t asBool EBool EAnd
|
||||||
Just OpOr -> nest t asBool EBool EOr
|
Just OpOr -> nest t asBool EBool EOr
|
||||||
_ -> pure t
|
_ -> pure t
|
||||||
|
|
||||||
nest
|
nest ::
|
||||||
:: forall a
|
forall a.
|
||||||
. Result
|
Result ->
|
||||||
-> (Result -> Either Text a)
|
(Result -> Either Text a) ->
|
||||||
-> (a -> Expr)
|
(a -> Expr) ->
|
||||||
-> (Expr -> Expr -> Expr)
|
(Expr -> Expr -> Expr) ->
|
||||||
-> Parser Result
|
Parser Result
|
||||||
nest t cast f bin = do
|
nest t cast f bin = do
|
||||||
t' <- term
|
t' <- term
|
||||||
a <- either (fail . unpack) pure do
|
a <- either (fail . unpack) pure do
|
||||||
lhs <- cast t
|
lhs <- cast t
|
||||||
rhs <- cast t'
|
rhs <- cast t'
|
||||||
toResult $ bin (f lhs) (f rhs)
|
toResult $ bin (f lhs) (f rhs)
|
||||||
a `deepseq` expr a
|
a `deepseq` expr a
|
||||||
|
|
||||||
term = do
|
term = do
|
||||||
p <- M.option Nothing $ Just <$> symbol "("
|
p <- M.option Nothing $ Just <$> symbol "("
|
||||||
if isJust p then (term >>= expr) <* symbol ")" else
|
if isJust p
|
||||||
RInt <$> integer <|> RBool <$> boolean
|
then (term >>= expr) <* symbol ")"
|
||||||
|
else RInt <$> integer <|> RBool <$> boolean
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- GADTs
|
-- GADTs
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
data GExpr a where
|
data GExpr a where
|
||||||
GInt :: Integer -> GExpr Integer
|
GInt :: Integer -> GExpr Integer
|
||||||
GBool :: Bool -> GExpr Bool
|
GBool :: Bool -> GExpr Bool
|
||||||
GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer
|
GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer
|
||||||
GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer
|
GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer
|
||||||
GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool
|
GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool
|
||||||
GOr :: GExpr Bool -> GExpr Bool -> GExpr Bool
|
GOr :: GExpr Bool -> GExpr Bool -> GExpr Bool
|
||||||
|
|
||||||
data Wrapper = forall a. Show a => Wrapper (GExpr a)
|
data Wrapper = forall a. Show a => Wrapper (GExpr a)
|
||||||
|
|
||||||
eval :: GExpr a -> a
|
eval :: GExpr a -> a
|
||||||
eval (GInt a) = a
|
eval (GInt a) = a
|
||||||
eval (GBool a) = a
|
eval (GBool a) = a
|
||||||
eval (GAdd lhs rhs) = eval lhs + eval rhs
|
eval (GAdd lhs rhs) = eval lhs + eval rhs
|
||||||
eval (GSub lhs rhs) = eval lhs - eval rhs
|
eval (GSub lhs rhs) = eval lhs - eval rhs
|
||||||
eval (GAnd lhs rhs) = eval lhs && eval rhs
|
eval (GAnd lhs rhs) = eval lhs && eval rhs
|
||||||
eval (GOr lhs rhs) = eval lhs || eval rhs
|
eval (GOr lhs rhs) = eval lhs || eval rhs
|
||||||
|
|
||||||
asInt' :: GExpr a -> Either Text (GExpr Integer)
|
asInt' :: GExpr a -> Either Text (GExpr Integer)
|
||||||
asInt' a@(GInt _ ) = pure a
|
asInt' a@(GInt _) = pure a
|
||||||
asInt' a@(GAdd _ _) = pure a
|
asInt' a@(GAdd _ _) = pure a
|
||||||
asInt' a@(GSub _ _) = pure a
|
asInt' a@(GSub _ _) = pure a
|
||||||
asInt' _ = Left "Expected an integer type."
|
asInt' _ = Left "Expected an integer type."
|
||||||
|
|
||||||
asBool' :: GExpr a -> Either Text (GExpr Bool)
|
asBool' :: GExpr a -> Either Text (GExpr Bool)
|
||||||
asBool' a@(GBool _ ) = pure a
|
asBool' a@(GBool _) = pure a
|
||||||
asBool' a@(GAnd _ _) = pure a
|
asBool' a@(GAnd _ _) = pure a
|
||||||
asBool' a@(GOr _ _) = pure a
|
asBool' a@(GOr _ _) = pure a
|
||||||
asBool' _ = Left "Expected a boolean type."
|
asBool' _ = Left "Expected a boolean type."
|
||||||
|
|
||||||
parseGadt :: Parser Wrapper
|
parseGadt :: Parser Wrapper
|
||||||
parseGadt = term >>= expr
|
parseGadt = term >>= expr
|
||||||
where
|
where
|
||||||
expr t = do
|
expr t = do
|
||||||
op <- M.option Nothing $ Just <$> ops
|
op <- M.option Nothing $ Just <$> ops
|
||||||
case op of
|
case op of
|
||||||
Just OpAdd -> nest t asInt' GInt GAdd
|
Just OpAdd -> nest t asInt' GInt GAdd
|
||||||
Just OpSub -> nest t asInt' GInt GSub
|
Just OpSub -> nest t asInt' GInt GSub
|
||||||
Just OpAnd -> nest t asBool' GBool GAnd
|
Just OpAnd -> nest t asBool' GBool GAnd
|
||||||
Just OpOr -> nest t asBool' GBool GOr
|
Just OpOr -> nest t asBool' GBool GOr
|
||||||
_ -> pure t
|
_ -> pure t
|
||||||
|
|
||||||
nest
|
nest ::
|
||||||
:: forall b
|
forall b.
|
||||||
. Show b
|
Show b =>
|
||||||
=> Wrapper
|
Wrapper ->
|
||||||
-> (forall a. GExpr a -> Either Text (GExpr b))
|
(forall a. GExpr a -> Either Text (GExpr b)) ->
|
||||||
-> (b -> GExpr b)
|
(b -> GExpr b) ->
|
||||||
-> (GExpr b -> GExpr b -> GExpr b)
|
(GExpr b -> GExpr b -> GExpr b) ->
|
||||||
-> Parser Wrapper
|
Parser Wrapper
|
||||||
nest (Wrapper t) cast f bin = do
|
nest (Wrapper t) cast f bin = do
|
||||||
Wrapper t' <- term
|
Wrapper t' <- term
|
||||||
case (cast t, cast t') of
|
case (cast t, cast t') of
|
||||||
(Right lhs, Right rhs) -> do
|
(Right lhs, Right rhs) -> do
|
||||||
let z = eval $ bin lhs rhs
|
let z = eval $ bin lhs rhs
|
||||||
z `seq` expr (Wrapper $ f z)
|
z `seq` expr (Wrapper $ f z)
|
||||||
(Left e, _) -> fail $ unpack e
|
(Left e, _) -> fail $ unpack e
|
||||||
(_, Left e) -> fail $ unpack e
|
(_, Left e) -> fail $ unpack e
|
||||||
|
|
||||||
term = do
|
term = do
|
||||||
p <- M.option Nothing $ Just <$> symbol "("
|
p <- M.option Nothing $ Just <$> symbol "("
|
||||||
if isJust p then (term >>= expr) <* symbol ")" else
|
if isJust p
|
||||||
Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean
|
then (term >>= expr) <* symbol ")"
|
||||||
|
else Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean
|
||||||
|
|
|
@ -4,41 +4,42 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Test.Parser.InitialTest
|
module Test.Parser.InitialTest
|
||||||
( spec_parser,
|
( spec_parser,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
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.Initial
|
import Parser.Initial
|
||||||
import Parser.Utils (Parser, allEqual, runParser)
|
import Parser.Utils (Parser, allEqual, runParser)
|
||||||
import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
||||||
|
import qualified Text.Megaparsec as M
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Utility
|
-- Utility
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
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
|
||||||
convert (GAdd lhs rhs) = EAdd (convert lhs) (convert rhs)
|
convert (GAdd lhs rhs) = EAdd (convert lhs) (convert rhs)
|
||||||
convert (GSub lhs rhs) = ESub (convert lhs) (convert rhs)
|
convert (GSub lhs rhs) = ESub (convert lhs) (convert rhs)
|
||||||
convert (GAnd lhs rhs) = EAnd (convert lhs) (convert rhs)
|
convert (GAnd lhs rhs) = EAnd (convert lhs) (convert rhs)
|
||||||
convert (GOr lhs rhs) = EOr (convert lhs) (convert rhs)
|
convert (GOr lhs rhs) = EOr (convert lhs) (convert rhs)
|
||||||
|
|
||||||
runParsers :: Text -> [Either Text Result]
|
runParsers :: Text -> [Either Text Result]
|
||||||
runParsers input =
|
runParsers input =
|
||||||
[ runParser parseNaive
|
[ runParser parseNaive,
|
||||||
, runParser parseSingle
|
runParser parseSingle,
|
||||||
, runParser parseStrict
|
runParser parseStrict,
|
||||||
, runGadt
|
runGadt
|
||||||
] <*> [input]
|
]
|
||||||
where
|
<*> [input]
|
||||||
runGadt i = do
|
where
|
||||||
Wrapper res <- runParser parseGadt i
|
runGadt i = do
|
||||||
toResult $ convert res
|
Wrapper res <- runParser parseGadt i
|
||||||
|
toResult $ convert res
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Assertions
|
-- Assertions
|
||||||
|
@ -84,7 +85,9 @@ spec_parser = do
|
||||||
shouldParse "false || false" (RBool False)
|
shouldParse "false || false" (RBool False)
|
||||||
describe "invalid types" do
|
describe "invalid types" do
|
||||||
it "mismatch" do
|
it "mismatch" do
|
||||||
shouldNotParse "true && 1"
|
shouldNotParse
|
||||||
|
"true && 1"
|
||||||
"1:10:\n |\n1 | true && 1\n | ^\nCould not cast boolean.\n"
|
"1:10:\n |\n1 | true && 1\n | ^\nCould not cast boolean.\n"
|
||||||
shouldNotParse "1 + true"
|
shouldNotParse
|
||||||
|
"1 + true"
|
||||||
"1:9:\n |\n1 | 1 + true\n | ^\nCould not cast integer.\n"
|
"1:9:\n |\n1 | 1 + true\n | ^\nCould not cast integer.\n"
|
||||||
|
|
|
@ -3,26 +3,28 @@
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Data.Eq.Type ((:=)(..), refl)
|
import Data.Eq.Type (refl, (:=) (..))
|
||||||
|
|
||||||
newtype F1 t b a = F1 {runF1 :: t := (a -> b)}
|
newtype F1 t b a = F1 {runF1 :: t := (a -> b)}
|
||||||
|
|
||||||
newtype F2 t a b = F2 {runF2 :: t := (a -> b)}
|
newtype F2 t a b = F2 {runF2 :: t := (a -> b)}
|
||||||
|
|
||||||
|
functionEquality ::
|
||||||
|
forall a1 a2 b1 b2.
|
||||||
|
a1 := a2 ->
|
||||||
|
b1 := b2 ->
|
||||||
|
(a1 -> b1) := (a2 -> b2)
|
||||||
functionEquality
|
functionEquality
|
||||||
:: forall a1 a2 b1 b2
|
(Refl s1) -- s1 :: forall c. c a1 -> c a2
|
||||||
. a1 := a2
|
(Refl s2) -- s2 :: forall c. c b1 -> c b2
|
||||||
-> b1 := b2
|
=
|
||||||
-> (a1 -> b1) := (a2 -> b2)
|
runF2 -- (a1 -> b1) := (a2 -> b2)
|
||||||
functionEquality
|
. s2 -- F2 (a1 -> b1) a2 b2
|
||||||
(Refl s1) -- s1 :: forall c. c a1 -> c a2
|
. F2 -- F2 (a1 -> b1) a2 b1
|
||||||
(Refl s2) -- s2 :: forall c. c b1 -> c b2
|
. runF1 -- (a1 -> b1) := (a2 -> b1)
|
||||||
= runF2 -- (a1 -> b1) := (a2 -> b2)
|
. s1 -- F1 (a1 -> b1) b1 a2
|
||||||
. s2 -- F2 (a1 -> b1) a2 b2
|
. F1 -- F1 (a1 -> b1) b1 a1
|
||||||
. F2 -- F2 (a1 -> b1) a2 b1
|
$ refl -- (a1 -> b1) := (a1 -> b1)
|
||||||
. runF1 -- (a1 -> b1) := (a2 -> b1)
|
|
||||||
. s1 -- F1 (a1 -> b1) b1 a2
|
|
||||||
. F1 -- F1 (a1 -> b1) b1 a1
|
|
||||||
$ refl -- (a1 -> b1) := (a1 -> b1)
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = putStrLn "Hello, Haskell!"
|
main = putStrLn "Hello, Haskell!"
|
||||||
|
|
|
@ -2,28 +2,28 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Parser.Utils
|
module Parser.Utils
|
||||||
( Op(..)
|
( Op (..),
|
||||||
, Parser
|
Parser,
|
||||||
, ParserT
|
ParserT,
|
||||||
, allEqual
|
allEqual,
|
||||||
, boolean
|
boolean,
|
||||||
, integer
|
integer,
|
||||||
, lexeme
|
lexeme,
|
||||||
, ops
|
ops,
|
||||||
, parens
|
parens,
|
||||||
, runParser
|
runParser,
|
||||||
, space
|
space,
|
||||||
, symbol
|
symbol,
|
||||||
) where
|
)
|
||||||
|
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 Control.Applicative ((<|>))
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.Text (Text, pack)
|
import Data.Text (Text, pack)
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
|
import qualified Text.Megaparsec as M
|
||||||
|
import qualified Text.Megaparsec.Char as MC
|
||||||
|
import qualified Text.Megaparsec.Char.Lexer as ML
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Parsing
|
-- Parsing
|
||||||
|
@ -63,15 +63,16 @@ instance Show Op where
|
||||||
show OpAdd = "+"
|
show OpAdd = "+"
|
||||||
show OpSub = "-"
|
show OpSub = "-"
|
||||||
show OpAnd = "&&"
|
show OpAnd = "&&"
|
||||||
show OpOr = "||"
|
show OpOr = "||"
|
||||||
|
|
||||||
ops :: forall m. ParserT m Op
|
ops :: forall m. ParserT m Op
|
||||||
ops = M.choice
|
ops =
|
||||||
[ symbol "+" $> OpAdd
|
M.choice
|
||||||
, symbol "-" $> OpSub
|
[ symbol "+" $> OpAdd,
|
||||||
, symbol "&&" $> OpAnd
|
symbol "-" $> OpSub,
|
||||||
, symbol "||" $> OpOr
|
symbol "&&" $> OpAnd,
|
||||||
]
|
symbol "||" $> OpOr
|
||||||
|
]
|
||||||
|
|
||||||
runParser :: forall a. Parser a -> Text -> Either Text a
|
runParser :: forall a. Parser a -> Text -> Either Text a
|
||||||
runParser p input = case M.runParser (p <* M.eof) "" input of
|
runParser p input = case M.runParser (p <* M.eof) "" input of
|
||||||
|
@ -86,4 +87,4 @@ allEqual :: forall a. Eq a => [a] -> Bool
|
||||||
allEqual [] = True
|
allEqual [] = True
|
||||||
allEqual [x] = True
|
allEqual [x] = True
|
||||||
allEqual [x, y] = x == y
|
allEqual [x, y] = x == y
|
||||||
allEqual (x:y:xs) = x == y && allEqual (y : xs)
|
allEqual (x : y : xs) = x == y && allEqual (y : xs)
|
||||||
|
|
|
@ -3,15 +3,14 @@
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Options.Applicative as O
|
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.IO (hGetContents)
|
import Data.Text.IO (hGetContents)
|
||||||
import Options.Applicative ((<**>))
|
import Options.Applicative ((<**>))
|
||||||
|
import qualified Options.Applicative as O
|
||||||
import Parser.Final
|
import Parser.Final
|
||||||
import Parser.Utils
|
import Parser.Utils
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.IO (IOMode(ReadMode), openFile)
|
import System.IO (IOMode (ReadMode), openFile)
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Arguments
|
-- Arguments
|
||||||
|
@ -20,18 +19,20 @@ import System.IO (IOMode(ReadMode), openFile)
|
||||||
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text}
|
||||||
|
|
||||||
args :: O.Parser Args
|
args :: O.Parser Args
|
||||||
args = Args
|
args =
|
||||||
<$> O.strArgument
|
Args
|
||||||
|
<$> O.strArgument
|
||||||
( O.metavar "FILENAME" <> O.help "The file we want to parse."
|
( O.metavar "FILENAME" <> O.help "The file we want to parse."
|
||||||
)
|
)
|
||||||
<*> O.strOption
|
<*> O.strOption
|
||||||
( O.short 'm'
|
( O.short 'm'
|
||||||
<> O.long "method"
|
<> O.long "method"
|
||||||
<> O.metavar "METHOD"
|
<> O.metavar "METHOD"
|
||||||
<> O.showDefault
|
<> O.showDefault
|
||||||
<> O.value "single"
|
<> O.value "single"
|
||||||
<> O.help "The parse strategy we want to try. Should be one of 'single' \
|
<> O.help
|
||||||
\or 'strict'."
|
"The parse strategy we want to try. Should be one of 'single' \
|
||||||
|
\or 'strict'."
|
||||||
)
|
)
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
@ -54,13 +55,15 @@ run args = do
|
||||||
case argsMethod args of
|
case argsMethod args of
|
||||||
"single" -> runExpr parseSingle contents
|
"single" -> runExpr parseSingle contents
|
||||||
"strict" -> runExpr parseStrict contents
|
"strict" -> runExpr parseStrict contents
|
||||||
_ -> error "Encountered an invalid parsing strategy."
|
_ -> error "Encountered an invalid parsing strategy."
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = run =<< O.execParser opts
|
main = run =<< O.execParser opts
|
||||||
where
|
where
|
||||||
opts = O.info (args <**> O.helper)
|
opts =
|
||||||
( O.fullDesc
|
O.info
|
||||||
<> O.progDesc "Different parsing strategies using initial encoding"
|
(args <**> O.helper)
|
||||||
<> O.header "Initial encoding parsing"
|
( O.fullDesc
|
||||||
)
|
<> O.progDesc "Different parsing strategies using initial encoding"
|
||||||
|
<> O.header "Initial encoding parsing"
|
||||||
|
)
|
||||||
|
|
|
@ -11,32 +11,32 @@
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
module Parser.Final
|
module Parser.Final
|
||||||
( Dynamic(..)
|
( Dynamic (..),
|
||||||
, Eval(..)
|
Eval (..),
|
||||||
, SQ(..)
|
SQ (..),
|
||||||
, Symantics(..)
|
Symantics (..),
|
||||||
, TQ(..)
|
TQ (..),
|
||||||
, TextSymantics(..)
|
TextSymantics (..),
|
||||||
, Typeable(..)
|
Typeable (..),
|
||||||
, fromDyn
|
fromDyn,
|
||||||
, parseSingle
|
parseSingle,
|
||||||
, parseStrict
|
parseStrict,
|
||||||
, toDyn
|
toDyn,
|
||||||
, runBoth'
|
runBoth',
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import qualified Control.Monad.Combinators.Expr as E
|
|
||||||
import qualified Data.Eq.Type as EQ
|
|
||||||
import qualified Text.Megaparsec as M
|
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.DeepSeq (NFData(..), deepseq)
|
import Control.DeepSeq (NFData (..), deepseq)
|
||||||
import Control.Monad.Combinators (sepBy)
|
import Control.Monad.Combinators (sepBy)
|
||||||
|
import qualified Control.Monad.Combinators.Expr as E
|
||||||
import Data.Eq.Type ((:=))
|
import Data.Eq.Type ((:=))
|
||||||
|
import qualified Data.Eq.Type as EQ
|
||||||
import Data.Functor (void)
|
import Data.Functor (void)
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe (isJust)
|
||||||
import Data.Text (Text, drop, dropEnd, pack, unpack)
|
import Data.Text (Text, drop, dropEnd, pack, unpack)
|
||||||
import Parser.Utils
|
import Parser.Utils
|
||||||
|
import qualified Text.Megaparsec as M
|
||||||
import Prelude hiding (drop)
|
import Prelude hiding (drop)
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
@ -44,12 +44,12 @@ import Prelude hiding (drop)
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
class Symantics repr where
|
class Symantics repr where
|
||||||
eInt :: Integer -> repr Integer
|
eInt :: Integer -> repr Integer
|
||||||
eBool :: Bool -> repr Bool
|
eBool :: Bool -> repr Bool
|
||||||
eAdd :: repr Integer -> repr Integer -> repr Integer
|
eAdd :: repr Integer -> repr Integer -> repr Integer
|
||||||
eSub :: repr Integer -> repr Integer -> repr Integer
|
eSub :: repr Integer -> repr Integer -> repr Integer
|
||||||
eAnd :: repr Bool -> repr Bool -> repr Bool
|
eAnd :: repr Bool -> repr Bool -> repr Bool
|
||||||
eOr :: repr Bool -> repr Bool -> repr Bool
|
eOr :: repr Bool -> repr Bool -> repr Bool
|
||||||
|
|
||||||
class (Symantics repr) => TextSymantics repr where
|
class (Symantics repr) => TextSymantics repr where
|
||||||
eText :: Text -> repr Text
|
eText :: Text -> repr Text
|
||||||
|
@ -58,12 +58,12 @@ class (Symantics repr) => TextSymantics repr where
|
||||||
newtype Eval a = Eval {runEval :: a} deriving (Eq, Show)
|
newtype Eval a = Eval {runEval :: a} deriving (Eq, Show)
|
||||||
|
|
||||||
instance Symantics Eval where
|
instance Symantics Eval where
|
||||||
eInt = Eval
|
eInt = Eval
|
||||||
eBool = Eval
|
eBool = Eval
|
||||||
eAdd (Eval lhs) (Eval rhs) = Eval (lhs + rhs)
|
eAdd (Eval lhs) (Eval rhs) = Eval (lhs + rhs)
|
||||||
eSub (Eval lhs) (Eval rhs) = Eval (lhs - rhs)
|
eSub (Eval lhs) (Eval rhs) = Eval (lhs - rhs)
|
||||||
eAnd (Eval lhs) (Eval rhs) = Eval (lhs && rhs)
|
eAnd (Eval lhs) (Eval rhs) = Eval (lhs && rhs)
|
||||||
eOr (Eval lhs) (Eval rhs) = Eval (lhs || rhs)
|
eOr (Eval lhs) (Eval rhs) = Eval (lhs || rhs)
|
||||||
|
|
||||||
instance TextSymantics Eval where
|
instance TextSymantics Eval where
|
||||||
eText = Eval
|
eText = Eval
|
||||||
|
@ -74,35 +74,35 @@ instance TextSymantics Eval where
|
||||||
-- ========================================
|
-- ========================================
|
||||||
|
|
||||||
class Typeable repr where
|
class Typeable repr where
|
||||||
pInt :: repr Integer
|
pInt :: repr Integer
|
||||||
pBool :: repr Bool
|
pBool :: repr Bool
|
||||||
pText :: repr Text
|
pText :: repr Text
|
||||||
|
|
||||||
newtype TQ t = TQ {runTQ :: forall repr. Typeable repr => repr t}
|
newtype TQ t = TQ {runTQ :: forall repr. Typeable repr => repr t}
|
||||||
|
|
||||||
instance Typeable TQ where
|
instance Typeable TQ where
|
||||||
pInt = TQ pInt
|
pInt = TQ pInt
|
||||||
pBool = TQ pBool
|
pBool = TQ pBool
|
||||||
pText = TQ pText
|
pText = TQ pText
|
||||||
|
|
||||||
newtype AsInt a = AsInt (Maybe (a := Integer))
|
newtype AsInt a = AsInt (Maybe (a := Integer))
|
||||||
|
|
||||||
instance Typeable AsInt where
|
instance Typeable AsInt where
|
||||||
pInt = AsInt (Just EQ.refl)
|
pInt = AsInt (Just EQ.refl)
|
||||||
pBool = AsInt Nothing
|
pBool = AsInt Nothing
|
||||||
pText = AsInt Nothing
|
pText = AsInt Nothing
|
||||||
|
|
||||||
newtype AsBool a = AsBool (Maybe (a := Bool))
|
newtype AsBool a = AsBool (Maybe (a := Bool))
|
||||||
|
|
||||||
instance Typeable AsBool where
|
instance Typeable AsBool where
|
||||||
pInt = AsBool Nothing
|
pInt = AsBool Nothing
|
||||||
pBool = AsBool (Just EQ.refl)
|
pBool = AsBool (Just EQ.refl)
|
||||||
pText = AsBool Nothing
|
pText = AsBool Nothing
|
||||||
|
|
||||||
newtype AsText a = AsText (Maybe (a := Text))
|
newtype AsText a = AsText (Maybe (a := Text))
|
||||||
|
|
||||||
instance Typeable AsText where
|
instance Typeable AsText where
|
||||||
pInt = AsText Nothing
|
pInt = AsText Nothing
|
||||||
pBool = AsText Nothing
|
pBool = AsText Nothing
|
||||||
pText = AsText (Just EQ.refl)
|
pText = AsText (Just EQ.refl)
|
||||||
|
|
||||||
|
@ -141,14 +141,14 @@ fromDyn (Dynamic t e) = case t of
|
||||||
r' <- r
|
r' <- r
|
||||||
pure $ EQ.coerce (EQ.lift r') e
|
pure $ EQ.coerce (EQ.lift r') e
|
||||||
|
|
||||||
asDyn
|
asDyn ::
|
||||||
:: forall repr a
|
forall repr a.
|
||||||
. TextSymantics repr
|
TextSymantics repr =>
|
||||||
=> IsDynamic a
|
IsDynamic a =>
|
||||||
=> (repr a -> repr a -> repr a)
|
(repr a -> repr a -> repr a) ->
|
||||||
-> Dynamic repr
|
Dynamic repr ->
|
||||||
-> Dynamic repr
|
Dynamic repr ->
|
||||||
-> Maybe (Dynamic repr)
|
Maybe (Dynamic repr)
|
||||||
asDyn bin lhs rhs = do
|
asDyn bin lhs rhs = do
|
||||||
lhs' <- fromDyn lhs
|
lhs' <- fromDyn lhs
|
||||||
rhs' <- fromDyn rhs
|
rhs' <- fromDyn rhs
|
||||||
|
@ -160,25 +160,27 @@ asDyn bin lhs rhs = do
|
||||||
|
|
||||||
parseSingle :: forall repr. TextSymantics repr => Parser (Dynamic repr)
|
parseSingle :: forall repr. TextSymantics repr => Parser (Dynamic repr)
|
||||||
parseSingle = expr >>= either offsetFail pure
|
parseSingle = expr >>= either offsetFail pure
|
||||||
where
|
where
|
||||||
offsetFail (offset, msg) = M.setOffset offset >> fail msg
|
offsetFail (offset, msg) = M.setOffset offset >> fail msg
|
||||||
|
|
||||||
expr = E.makeExprParser term
|
expr =
|
||||||
[ [binary "+" eAdd, binary "-" eSub]
|
E.makeExprParser
|
||||||
, [binary "&&" eAnd, binary "||" eOr]
|
term
|
||||||
]
|
[ [binary "+" eAdd, binary "-" eSub],
|
||||||
|
[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 asDyn bin lhs' rhs' of
|
case asDyn bin lhs' rhs' of
|
||||||
Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
|
Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`")
|
||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
|
|
||||||
term = parens expr <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean
|
term = parens expr <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Strict
|
-- Strict
|
||||||
|
@ -190,41 +192,42 @@ instance (NFData t) => NFData (Eval t) where
|
||||||
instance NFData (Dynamic Eval) where
|
instance NFData (Dynamic Eval) where
|
||||||
rnf (Dynamic _ e) = e `seq` ()
|
rnf (Dynamic _ e) = e `seq` ()
|
||||||
|
|
||||||
parseStrict
|
parseStrict ::
|
||||||
:: forall repr
|
forall repr.
|
||||||
. NFData (Dynamic repr)
|
NFData (Dynamic repr) =>
|
||||||
=> TextSymantics repr
|
TextSymantics repr =>
|
||||||
=> Parser (Dynamic repr)
|
Parser (Dynamic repr)
|
||||||
parseStrict = term >>= expr
|
parseStrict = term >>= expr
|
||||||
where
|
where
|
||||||
expr :: Dynamic repr -> Parser (Dynamic repr)
|
expr :: Dynamic repr -> Parser (Dynamic repr)
|
||||||
expr t = do
|
expr t = do
|
||||||
op <- M.option Nothing $ Just <$> ops
|
op <- M.option Nothing $ Just <$> ops
|
||||||
case op of
|
case op of
|
||||||
Just OpAdd -> nest t eAdd OpAdd
|
Just OpAdd -> nest t eAdd OpAdd
|
||||||
Just OpSub -> nest t eSub OpSub
|
Just OpSub -> nest t eSub OpSub
|
||||||
Just OpAnd -> nest t eAnd OpAnd
|
Just OpAnd -> nest t eAnd OpAnd
|
||||||
Just OpOr -> nest t eOr OpOr
|
Just OpOr -> nest t eOr OpOr
|
||||||
_ -> pure t
|
_ -> pure t
|
||||||
|
|
||||||
nest
|
nest ::
|
||||||
:: forall a
|
forall a.
|
||||||
. IsDynamic a
|
IsDynamic a =>
|
||||||
=> Dynamic repr
|
Dynamic repr ->
|
||||||
-> (repr a -> repr a -> repr a)
|
(repr a -> repr a -> repr a) ->
|
||||||
-> Op
|
Op ->
|
||||||
-> Parser (Dynamic repr)
|
Parser (Dynamic repr)
|
||||||
nest t bin op = do
|
nest t bin op = do
|
||||||
t' <- term
|
t' <- term
|
||||||
case asDyn bin t t' of
|
case asDyn bin t t' of
|
||||||
Nothing -> fail $ "Invalid operands for `" <> show op <> "`"
|
Nothing -> fail $ "Invalid operands for `" <> show op <> "`"
|
||||||
Just a -> a `deepseq` expr a
|
Just a -> a `deepseq` expr a
|
||||||
|
|
||||||
term :: Parser (Dynamic repr)
|
term :: Parser (Dynamic repr)
|
||||||
term = do
|
term = do
|
||||||
p <- M.option Nothing $ Just <$> symbol "("
|
p <- M.option Nothing $ Just <$> symbol "("
|
||||||
if isJust p then (term >>= expr) <* symbol ")" else
|
if isJust p
|
||||||
toDyn <$> integer <|> toDyn <$> boolean
|
then (term >>= expr) <* symbol ")"
|
||||||
|
else toDyn <$> integer <|> toDyn <$> boolean
|
||||||
|
|
||||||
-- ========================================
|
-- ========================================
|
||||||
-- Pretty print
|
-- Pretty print
|
||||||
|
@ -233,12 +236,12 @@ parseStrict = term >>= expr
|
||||||
newtype PPrint a = PPrint {runPPrint :: Text} deriving (Eq, Show)
|
newtype PPrint a = PPrint {runPPrint :: Text} deriving (Eq, Show)
|
||||||
|
|
||||||
instance Symantics PPrint where
|
instance Symantics PPrint where
|
||||||
eInt = PPrint . pack . show
|
eInt = PPrint . pack . show
|
||||||
eBool = PPrint . pack . show
|
eBool = PPrint . pack . show
|
||||||
eAdd (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " + " <> rhs <> ")"
|
eAdd (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " + " <> rhs <> ")"
|
||||||
eSub (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " - " <> rhs <> ")"
|
eSub (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " - " <> rhs <> ")"
|
||||||
eAnd (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " && " <> rhs <> ")"
|
eAnd (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " && " <> rhs <> ")"
|
||||||
eOr (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " || " <> rhs <> ")"
|
eOr (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " || " <> rhs <> ")"
|
||||||
|
|
||||||
instance TextSymantics PPrint where
|
instance TextSymantics PPrint where
|
||||||
eText = PPrint
|
eText = PPrint
|
||||||
|
@ -265,22 +268,22 @@ instance MulSymantics PPrint where
|
||||||
newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
|
newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
|
||||||
|
|
||||||
instance Symantics SQ where
|
instance Symantics SQ where
|
||||||
eInt e = SQ (eInt e)
|
eInt e = SQ (eInt e)
|
||||||
eBool e = SQ (eBool e)
|
eBool e = SQ (eBool e)
|
||||||
eAdd (SQ lhs) (SQ rhs) = SQ (eAdd lhs rhs)
|
eAdd (SQ lhs) (SQ rhs) = SQ (eAdd lhs rhs)
|
||||||
eSub (SQ lhs) (SQ rhs) = SQ (eSub lhs rhs)
|
eSub (SQ lhs) (SQ rhs) = SQ (eSub lhs rhs)
|
||||||
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 MSQ a = MSQ {runMSQ :: forall repr. MulSymantics repr => repr a}
|
newtype MSQ a = MSQ {runMSQ :: forall repr. MulSymantics repr => repr a}
|
||||||
|
|
||||||
instance Symantics MSQ where
|
instance Symantics MSQ where
|
||||||
eInt e = MSQ (eInt e)
|
eInt e = MSQ (eInt e)
|
||||||
eBool e = MSQ (eBool e)
|
eBool e = MSQ (eBool e)
|
||||||
eAdd (MSQ lhs) (MSQ rhs) = MSQ (eAdd lhs rhs)
|
eAdd (MSQ lhs) (MSQ rhs) = MSQ (eAdd lhs rhs)
|
||||||
eSub (MSQ lhs) (MSQ rhs) = MSQ (eSub lhs rhs)
|
eSub (MSQ lhs) (MSQ rhs) = MSQ (eSub lhs rhs)
|
||||||
eAnd (MSQ lhs) (MSQ rhs) = MSQ (eAnd lhs rhs)
|
eAnd (MSQ lhs) (MSQ rhs) = MSQ (eAnd lhs rhs)
|
||||||
eOr (MSQ lhs) (MSQ rhs) = MSQ (eOr lhs rhs)
|
eOr (MSQ lhs) (MSQ rhs) = MSQ (eOr lhs rhs)
|
||||||
|
|
||||||
instance MulSymantics MSQ where
|
instance MulSymantics MSQ where
|
||||||
eMul (MSQ lhs) (MSQ rhs) = MSQ (eMul lhs rhs)
|
eMul (MSQ lhs) (MSQ rhs) = MSQ (eMul lhs rhs)
|
||||||
|
@ -317,41 +320,45 @@ pPrint' d = case fromDyn @MSQ @Integer d of
|
||||||
|
|
||||||
data SCopy repr1 repr2 a = SCopy (repr1 a) (repr2 a)
|
data SCopy repr1 repr2 a = SCopy (repr1 a) (repr2 a)
|
||||||
|
|
||||||
instance (Symantics repr1, Symantics repr2)
|
instance
|
||||||
=> Symantics (SCopy repr1 repr2) where
|
(Symantics repr1, Symantics repr2) =>
|
||||||
eInt e = SCopy (eInt e) (eInt e)
|
Symantics (SCopy repr1 repr2)
|
||||||
|
where
|
||||||
|
eInt e = SCopy (eInt e) (eInt e)
|
||||||
eBool e = SCopy (eBool e) (eBool e)
|
eBool e = SCopy (eBool e) (eBool e)
|
||||||
eAdd (SCopy a1 a2) (SCopy b1 b2) = SCopy (eAdd a1 b1) (eAdd a2 b2)
|
eAdd (SCopy a1 a2) (SCopy b1 b2) = SCopy (eAdd a1 b1) (eAdd a2 b2)
|
||||||
eSub (SCopy a1 a2) (SCopy b1 b2) = SCopy (eSub a1 b1) (eSub a2 b2)
|
eSub (SCopy a1 a2) (SCopy b1 b2) = SCopy (eSub a1 b1) (eSub a2 b2)
|
||||||
eAnd (SCopy a1 a2) (SCopy b1 b2) = SCopy (eAnd a1 b1) (eAnd a2 b2)
|
eAnd (SCopy a1 a2) (SCopy b1 b2) = SCopy (eAnd a1 b1) (eAnd a2 b2)
|
||||||
eOr (SCopy a1 a2) (SCopy b1 b2) = SCopy (eOr a1 b1) (eOr a2 b2)
|
eOr (SCopy a1 a2) (SCopy b1 b2) = SCopy (eOr a1 b1) (eOr a2 b2)
|
||||||
|
|
||||||
instance (MulSymantics repr1, MulSymantics repr2)
|
instance
|
||||||
=> MulSymantics (SCopy repr1 repr2) where
|
(MulSymantics repr1, MulSymantics repr2) =>
|
||||||
|
MulSymantics (SCopy repr1 repr2)
|
||||||
|
where
|
||||||
eMul (SCopy a1 a2) (SCopy b1 b2) = SCopy (eMul a1 b1) (eMul a2 b2)
|
eMul (SCopy a1 a2) (SCopy b1 b2) = SCopy (eMul a1 b1) (eMul a2 b2)
|
||||||
|
|
||||||
runEval'
|
runEval' ::
|
||||||
:: forall repr
|
forall repr.
|
||||||
. Dynamic (SCopy Eval repr)
|
Dynamic (SCopy Eval repr) ->
|
||||||
-> Maybe (Result, Dynamic repr)
|
Maybe (Result, Dynamic repr)
|
||||||
runEval' d = case fromDyn d :: Maybe (SCopy Eval repr Integer) of
|
runEval' d = case fromDyn d :: Maybe (SCopy Eval repr Integer) of
|
||||||
Just (SCopy (Eval a) r) -> pure (RInt a, Dynamic pInt r)
|
Just (SCopy (Eval a) r) -> pure (RInt a, Dynamic pInt r)
|
||||||
Nothing -> case fromDyn d :: Maybe (SCopy Eval repr Bool) of
|
Nothing -> case fromDyn d :: Maybe (SCopy Eval repr Bool) of
|
||||||
Just (SCopy (Eval a) r) -> pure (RBool a, Dynamic pBool r)
|
Just (SCopy (Eval a) r) -> pure (RBool a, Dynamic pBool r)
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
|
|
||||||
runPPrint'
|
runPPrint' ::
|
||||||
:: forall repr
|
forall repr.
|
||||||
. Dynamic (SCopy PPrint repr)
|
Dynamic (SCopy PPrint repr) ->
|
||||||
-> Maybe (Text, Dynamic repr)
|
Maybe (Text, Dynamic repr)
|
||||||
runPPrint' d = case fromDyn d :: Maybe (SCopy PPrint repr Text) of
|
runPPrint' d = case fromDyn d :: Maybe (SCopy PPrint repr Text) of
|
||||||
Just (SCopy (PPrint a) r) -> pure (a, Dynamic pText r)
|
Just (SCopy (PPrint a) r) -> pure (a, Dynamic pText r)
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
|
|
||||||
runBoth'
|
runBoth' ::
|
||||||
:: forall repr
|
forall repr.
|
||||||
. Dynamic (SCopy Eval (SCopy PPrint repr))
|
Dynamic (SCopy Eval (SCopy PPrint repr)) ->
|
||||||
-> Maybe (Result, Text, Dynamic repr)
|
Maybe (Result, Text, Dynamic repr)
|
||||||
runBoth' d = do
|
runBoth' d = do
|
||||||
(r, d') <- runEval' d
|
(r, d') <- runEval' d
|
||||||
(p, d'') <- runPPrint' d'
|
(p, d'') <- runPPrint' d'
|
||||||
|
|
|
@ -5,8 +5,9 @@
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Test.Parser.FinalTest
|
module Test.Parser.FinalTest
|
||||||
( spec_parser,
|
( spec_parser,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Parser.Final
|
import Parser.Final
|
||||||
|
@ -78,7 +79,9 @@ spec_parser = do
|
||||||
shouldParse "false || false" (toDyn False)
|
shouldParse "false || false" (toDyn False)
|
||||||
describe "invalid types" do
|
describe "invalid types" do
|
||||||
it "mismatch" do
|
it "mismatch" do
|
||||||
shouldNotParse "true && 1"
|
shouldNotParse
|
||||||
|
"true && 1"
|
||||||
"1:9:\n |\n1 | true && 1\n | ^\nInvalid operands for `&&`\n"
|
"1:9:\n |\n1 | true && 1\n | ^\nInvalid operands for `&&`\n"
|
||||||
shouldNotParse "1 + true"
|
shouldNotParse
|
||||||
|
"1 + true"
|
||||||
"1:5:\n |\n1 | 1 + true\n | ^\nInvalid operands for `+`\n"
|
"1:5:\n |\n1 | 1 + true\n | ^\nInvalid operands for `+`\n"
|
||||||
|
|
Loading…
Reference in New Issue