diff --git a/.githooks/pre-commit b/.githooks/pre-commit new file mode 100755 index 0000000..2606d55 --- /dev/null +++ b/.githooks/pre-commit @@ -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; diff --git a/README.md b/README.md index 1470455..cbe71b7 100644 --- a/README.md +++ b/README.md @@ -34,3 +34,11 @@ $ direnv allow 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. + +## Formatting + +Link in `.githooks` by running: + +```bash +$ git config --local core.hooksPath .githooks/ +``` diff --git a/flake.nix b/flake.nix index 6d3c220..c6f25a7 100644 --- a/flake.nix +++ b/flake.nix @@ -25,6 +25,7 @@ # https://www.reddit.com/r/Nix/comments/jyczts/nixshell_locale_issue/ pkgs.glibcLocales pkgs.haskellPackages.cabal-install + pkgs.haskellPackages.ormolu pkgs.haskellPackages.tasty-discover ]; }; diff --git a/initial-encoding/app/Main.hs b/initial-encoding/app/Main.hs index e74fd41..6136f29 100644 --- a/initial-encoding/app/Main.hs +++ b/initial-encoding/app/Main.hs @@ -2,16 +2,15 @@ module Main where -import qualified Options.Applicative as O -import qualified Text.Megaparsec as M - import Data.Text (Text) import Data.Text.IO (hGetContents) import Options.Applicative ((<**>)) +import qualified Options.Applicative as O import Parser.Initial import Parser.Utils import System.Environment (getArgs) -import System.IO (IOMode(ReadMode), openFile) +import System.IO (IOMode (ReadMode), openFile) +import qualified Text.Megaparsec as M -- ======================================== -- Arguments @@ -20,18 +19,20 @@ import System.IO (IOMode(ReadMode), openFile) data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text} args :: O.Parser Args -args = Args - <$> O.strArgument +args = + Args + <$> O.strArgument ( O.metavar "FILENAME" <> O.help "The file we want to parse." ) - <*> O.strOption + <*> O.strOption ( O.short 'm' - <> O.long "method" - <> O.metavar "METHOD" - <> O.showDefault - <> O.value "naive" - <> O.help "The parse strategy we want to try. Should be one of 'naive', \ - \'single', 'strict', or 'gadt'." + <> O.long "method" + <> O.metavar "METHOD" + <> O.showDefault + <> O.value "naive" + <> O.help + "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 input <- hGetContents handle case argsMethod args of - "naive" -> runExpr parseNaive input + "naive" -> runExpr parseNaive input "single" -> runExpr parseSingle input "strict" -> runExpr parseStrict input - "gadt" -> case runParser parseGadt input of - Left e -> print e - Right (Wrapper a) -> print $ eval a - _ -> error "Encountered an invalid parsing strategy." - where - runExpr p input = either print print (runParser p input) + "gadt" -> case runParser parseGadt input of + Left e -> print e + Right (Wrapper a) -> print $ eval a + _ -> error "Encountered an invalid parsing strategy." + where + runExpr p input = either print print (runParser p input) main :: IO () main = run =<< O.execParser opts - where - opts = O.info (args <**> O.helper) - ( O.fullDesc - <> O.progDesc "Different parsing strategies using initial encoding" - <> O.header "Initial encoding parsing" - ) + where + opts = + O.info + (args <**> O.helper) + ( O.fullDesc + <> O.progDesc "Different parsing strategies using initial encoding" + <> O.header "Initial encoding parsing" + ) diff --git a/initial-encoding/src/Parser/Initial.hs b/initial-encoding/src/Parser/Initial.hs index c39fc76..3a10dc6 100644 --- a/initial-encoding/src/Parser/Initial.hs +++ b/initial-encoding/src/Parser/Initial.hs @@ -6,48 +6,48 @@ {-# LANGUAGE ScopedTypeVariables #-} module Parser.Initial -( Expr(..) -, GExpr(..) -, Result(..) -, Wrapper(..) -, eval -, parseGadt -, parseNaive -, parseSingle -, parseStrict -, toResult -) where - -import qualified Control.Monad.Combinators.Expr as E -import qualified Text.Megaparsec as M + ( Expr (..), + GExpr (..), + Result (..), + Wrapper (..), + eval, + parseGadt, + parseNaive, + parseSingle, + parseStrict, + toResult, + ) +where import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..), deepseq) +import Control.DeepSeq (NFData (..), deepseq) import Control.Monad (join) +import qualified Control.Monad.Combinators.Expr as E import Control.Monad.Except (MonadError, throwError) import Data.Bifunctor (bimap, first) import Data.Functor (void) import Data.Maybe (isJust) import Data.Text (Text, pack, unpack) import Parser.Utils +import qualified Text.Megaparsec as M -- ======================================== -- ADT -- ======================================== data Expr - = EInt Integer + = EInt Integer | EBool Bool - | EAdd Expr Expr - | ESub Expr Expr - | EAnd Expr Expr - | EOr Expr Expr + | EAdd Expr Expr + | ESub Expr Expr + | EAnd Expr Expr + | EOr Expr Expr deriving (Eq, Show) data Result = RInt Integer | RBool Bool deriving (Eq) instance Show Result where - show (RInt e) = show e + show (RInt e) = show e show (RBool e) = show e asInt :: Result -> Either Text Integer @@ -59,7 +59,7 @@ asBool (RBool e) = pure e asBool _ = Left "Could not cast boolean." toResult :: Expr -> Either Text Result -toResult (EInt e) = pure $ RInt e +toResult (EInt e) = pure $ RInt e toResult (EBool e) = pure $ RBool e toResult (EAdd lhs rhs) = do lhs' <- toResult lhs >>= asInt @@ -84,15 +84,17 @@ toResult (EOr lhs rhs) = do parseNaive :: Parser Result parseNaive = expr >>= either (fail . unpack) pure . toResult - where - expr = E.makeExprParser term - [ [binary "+" EAdd, binary "-" ESub] - , [binary "&&" EAnd, binary "||" EOr] - ] + where + expr = + E.makeExprParser + 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 @@ -100,20 +102,22 @@ parseNaive = expr >>= either (fail . unpack) pure . toResult parseSingle :: Parser Result parseSingle = expr >>= either (fail . unpack) pure - where - expr = E.makeExprParser term - [ [binary "+" asInt EInt EAdd, binary "-" asInt EInt ESub] - , [binary "&&" asBool EBool EAnd, binary "||" asBool EBool EOr ] - ] + where + expr = + E.makeExprParser + 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 - void $ symbol name - pure $ \lhs rhs -> do - lhs' <- lhs >>= cast - rhs' <- rhs >>= cast - toResult $ bin (f lhs') (f rhs') + binary name cast f bin = E.InfixL do + void $ symbol name + pure $ \lhs rhs -> do + lhs' <- lhs >>= cast + rhs' <- rhs >>= cast + 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 @@ -125,100 +129,102 @@ instance NFData Result where parseStrict :: Parser Result parseStrict = term >>= expr - where - expr t = do - op <- M.option Nothing $ Just <$> ops - case op of - Just OpAdd -> nest t asInt EInt EAdd - Just OpSub -> nest t asInt EInt ESub - Just OpAnd -> nest t asBool EBool EAnd - Just OpOr -> nest t asBool EBool EOr - _ -> pure t + where + expr t = do + op <- M.option Nothing $ Just <$> ops + case op of + Just OpAdd -> nest t asInt EInt EAdd + Just OpSub -> nest t asInt EInt ESub + Just OpAnd -> nest t asBool EBool EAnd + Just OpOr -> nest t asBool EBool EOr + _ -> pure t - nest - :: forall a - . Result - -> (Result -> Either Text a) - -> (a -> Expr) - -> (Expr -> Expr -> Expr) - -> Parser Result - nest t cast f bin = do - t' <- term - a <- either (fail . unpack) pure do - lhs <- cast t - rhs <- cast t' - toResult $ bin (f lhs) (f rhs) - a `deepseq` expr a + nest :: + forall a. + Result -> + (Result -> Either Text a) -> + (a -> Expr) -> + (Expr -> Expr -> Expr) -> + Parser Result + nest t cast f bin = do + t' <- term + a <- either (fail . unpack) pure do + lhs <- cast t + rhs <- cast t' + toResult $ bin (f lhs) (f rhs) + a `deepseq` expr a - term = do - p <- M.option Nothing $ Just <$> symbol "(" - if isJust p then (term >>= expr) <* symbol ")" else - RInt <$> integer <|> RBool <$> boolean + term = do + p <- M.option Nothing $ Just <$> symbol "(" + if isJust p + then (term >>= expr) <* symbol ")" + else RInt <$> integer <|> RBool <$> boolean -- ======================================== -- GADTs -- ======================================== data GExpr a where - GInt :: Integer -> GExpr Integer + GInt :: Integer -> GExpr Integer GBool :: Bool -> GExpr Bool - GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer - GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer - GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool - GOr :: GExpr Bool -> GExpr Bool -> GExpr Bool + GAdd :: GExpr Integer -> GExpr Integer -> GExpr Integer + GSub :: GExpr Integer -> GExpr Integer -> GExpr Integer + GAnd :: GExpr Bool -> GExpr Bool -> GExpr Bool + GOr :: GExpr Bool -> GExpr Bool -> GExpr Bool data Wrapper = forall a. Show a => Wrapper (GExpr a) eval :: GExpr a -> a -eval (GInt a) = a +eval (GInt a) = a eval (GBool a) = a eval (GAdd lhs rhs) = eval lhs + eval rhs eval (GSub 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' a@(GInt _ ) = pure a +asInt' a@(GInt _) = pure a asInt' a@(GAdd _ _) = 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' a@(GBool _ ) = pure a -asBool' a@(GAnd _ _) = pure a -asBool' a@(GOr _ _) = pure a -asBool' _ = Left "Expected a boolean type." +asBool' a@(GBool _) = pure a +asBool' a@(GAnd _ _) = pure a +asBool' a@(GOr _ _) = pure a +asBool' _ = Left "Expected a boolean type." parseGadt :: Parser Wrapper parseGadt = term >>= expr - where - expr t = do - op <- M.option Nothing $ Just <$> ops - case op of - Just OpAdd -> nest t asInt' GInt GAdd - Just OpSub -> nest t asInt' GInt GSub - Just OpAnd -> nest t asBool' GBool GAnd - Just OpOr -> nest t asBool' GBool GOr - _ -> pure t + where + expr t = do + op <- M.option Nothing $ Just <$> ops + case op of + Just OpAdd -> nest t asInt' GInt GAdd + Just OpSub -> nest t asInt' GInt GSub + Just OpAnd -> nest t asBool' GBool GAnd + Just OpOr -> nest t asBool' GBool GOr + _ -> pure t - nest - :: forall b - . Show b - => Wrapper - -> (forall a. GExpr a -> Either Text (GExpr b)) - -> (b -> GExpr b) - -> (GExpr b -> GExpr b -> GExpr b) - -> Parser Wrapper - nest (Wrapper t) cast f bin = do - Wrapper t' <- term - case (cast t, cast t') of - (Right lhs, Right rhs) -> do - let z = eval $ bin lhs rhs - z `seq` expr (Wrapper $ f z) - (Left e, _) -> fail $ unpack e - (_, Left e) -> fail $ unpack e + nest :: + forall b. + Show b => + Wrapper -> + (forall a. GExpr a -> Either Text (GExpr b)) -> + (b -> GExpr b) -> + (GExpr b -> GExpr b -> GExpr b) -> + Parser Wrapper + nest (Wrapper t) cast f bin = do + Wrapper t' <- term + case (cast t, cast t') of + (Right lhs, Right rhs) -> do + let z = eval $ bin lhs rhs + z `seq` expr (Wrapper $ f z) + (Left e, _) -> fail $ unpack e + (_, Left e) -> fail $ unpack e - term = do - p <- M.option Nothing $ Just <$> symbol "(" - if isJust p then (term >>= expr) <* symbol ")" else - Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean + term = do + p <- M.option Nothing $ Just <$> symbol "(" + if isJust p + then (term >>= expr) <* symbol ")" + else Wrapper . GInt <$> integer <|> Wrapper . GBool <$> boolean diff --git a/initial-encoding/test/Test/Parser/InitialTest.hs b/initial-encoding/test/Test/Parser/InitialTest.hs index c66265c..696df2b 100644 --- a/initial-encoding/test/Test/Parser/InitialTest.hs +++ b/initial-encoding/test/Test/Parser/InitialTest.hs @@ -4,41 +4,42 @@ {-# LANGUAGE OverloadedStrings #-} module Test.Parser.InitialTest -( spec_parser, -) where - -import qualified Text.Megaparsec as M + ( spec_parser, + ) +where import Data.Bifunctor (first) -import Data.Functor.Identity (Identity(..)) +import Data.Functor.Identity (Identity (..)) import Data.Text (Text, pack) import Parser.Initial import Parser.Utils (Parser, allEqual, runParser) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) +import qualified Text.Megaparsec as M -- ======================================== -- Utility -- ======================================== convert :: GExpr a -> Expr -convert (GInt a) = EInt a +convert (GInt a) = EInt a convert (GBool a) = EBool a convert (GAdd lhs rhs) = EAdd (convert lhs) (convert rhs) convert (GSub lhs rhs) = ESub (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 input = - [ runParser parseNaive - , runParser parseSingle - , runParser parseStrict - , runGadt - ] <*> [input] - where - runGadt i = do - Wrapper res <- runParser parseGadt i - toResult $ convert res + [ runParser parseNaive, + runParser parseSingle, + runParser parseStrict, + runGadt + ] + <*> [input] + where + runGadt i = do + Wrapper res <- runParser parseGadt i + toResult $ convert res -- ======================================== -- Assertions @@ -84,7 +85,9 @@ spec_parser = do shouldParse "false || false" (RBool False) describe "invalid types" do it "mismatch" do - shouldNotParse "true && 1" + shouldNotParse + "true && 1" "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" diff --git a/leibniz-proof/app/Main.hs b/leibniz-proof/app/Main.hs index 95e6688..cbb615b 100644 --- a/leibniz-proof/app/Main.hs +++ b/leibniz-proof/app/Main.hs @@ -3,26 +3,28 @@ module Main where -import Data.Eq.Type ((:=)(..), refl) +import Data.Eq.Type (refl, (:=) (..)) newtype F1 t b a = F1 {runF1 :: 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 - :: forall a1 a2 b1 b2 - . a1 := a2 - -> b1 := b2 - -> (a1 -> b1) := (a2 -> b2) -functionEquality - (Refl s1) -- s1 :: forall c. c a1 -> c a2 - (Refl s2) -- s2 :: forall c. c b1 -> c b2 - = runF2 -- (a1 -> b1) := (a2 -> b2) - . s2 -- F2 (a1 -> b1) a2 b2 - . F2 -- F2 (a1 -> b1) a2 b1 - . runF1 -- (a1 -> b1) := (a2 -> b1) - . s1 -- F1 (a1 -> b1) b1 a2 - . F1 -- F1 (a1 -> b1) b1 a1 - $ refl -- (a1 -> b1) := (a1 -> b1) + (Refl s1) -- s1 :: forall c. c a1 -> c a2 + (Refl s2) -- s2 :: forall c. c b1 -> c b2 + = + runF2 -- (a1 -> b1) := (a2 -> b2) + . s2 -- F2 (a1 -> b1) a2 b2 + . F2 -- F2 (a1 -> b1) a2 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 = putStrLn "Hello, Haskell!" diff --git a/parser-utils/src/Parser/Utils.hs b/parser-utils/src/Parser/Utils.hs index 78b7614..90ad603 100644 --- a/parser-utils/src/Parser/Utils.hs +++ b/parser-utils/src/Parser/Utils.hs @@ -2,28 +2,28 @@ {-# LANGUAGE OverloadedStrings #-} module Parser.Utils -( Op(..) -, Parser -, ParserT -, allEqual -, boolean -, integer -, lexeme -, ops -, parens -, runParser -, space -, symbol -) where - -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as MC -import qualified Text.Megaparsec.Char.Lexer as ML + ( Op (..), + Parser, + ParserT, + allEqual, + boolean, + integer, + lexeme, + ops, + parens, + runParser, + space, + symbol, + ) +where import Control.Applicative ((<|>)) import Data.Functor (($>)) import Data.Text (Text, pack) 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 @@ -63,15 +63,16 @@ instance Show Op where show OpAdd = "+" show OpSub = "-" show OpAnd = "&&" - show OpOr = "||" + show OpOr = "||" ops :: forall m. ParserT m Op -ops = M.choice - [ symbol "+" $> OpAdd - , symbol "-" $> OpSub - , symbol "&&" $> OpAnd - , symbol "||" $> OpOr - ] +ops = + M.choice + [ symbol "+" $> OpAdd, + symbol "-" $> OpSub, + symbol "&&" $> OpAnd, + symbol "||" $> OpOr + ] runParser :: forall a. Parser a -> Text -> Either Text a 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 [x] = True allEqual [x, y] = x == y -allEqual (x:y:xs) = x == y && allEqual (y : xs) +allEqual (x : y : xs) = x == y && allEqual (y : xs) diff --git a/tagless-final/app/Main.hs b/tagless-final/app/Main.hs index f732548..70eac7d 100644 --- a/tagless-final/app/Main.hs +++ b/tagless-final/app/Main.hs @@ -3,15 +3,14 @@ module Main where -import qualified Options.Applicative as O - import Data.Text (Text) import Data.Text.IO (hGetContents) import Options.Applicative ((<**>)) +import qualified Options.Applicative as O import Parser.Final import Parser.Utils import System.Environment (getArgs) -import System.IO (IOMode(ReadMode), openFile) +import System.IO (IOMode (ReadMode), openFile) -- ======================================== -- Arguments @@ -20,18 +19,20 @@ import System.IO (IOMode(ReadMode), openFile) data Args = Args {argsFileName :: !FilePath, argsMethod :: !Text} args :: O.Parser Args -args = Args - <$> O.strArgument +args = + Args + <$> O.strArgument ( O.metavar "FILENAME" <> O.help "The file we want to parse." ) - <*> O.strOption + <*> O.strOption ( O.short 'm' - <> O.long "method" - <> O.metavar "METHOD" - <> O.showDefault - <> O.value "single" - <> O.help "The parse strategy we want to try. Should be one of 'single' \ - \or 'strict'." + <> O.long "method" + <> O.metavar "METHOD" + <> O.showDefault + <> O.value "single" + <> O.help + "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 "single" -> runExpr parseSingle contents "strict" -> runExpr parseStrict contents - _ -> error "Encountered an invalid parsing strategy." + _ -> error "Encountered an invalid parsing strategy." main :: IO () main = run =<< O.execParser opts - where - opts = O.info (args <**> O.helper) - ( O.fullDesc - <> O.progDesc "Different parsing strategies using initial encoding" - <> O.header "Initial encoding parsing" - ) + where + opts = + O.info + (args <**> O.helper) + ( O.fullDesc + <> O.progDesc "Different parsing strategies using initial encoding" + <> O.header "Initial encoding parsing" + ) diff --git a/tagless-final/src/Parser/Final.hs b/tagless-final/src/Parser/Final.hs index a2c0ac3..b4d8c8e 100644 --- a/tagless-final/src/Parser/Final.hs +++ b/tagless-final/src/Parser/Final.hs @@ -11,32 +11,32 @@ {-# LANGUAGE ViewPatterns #-} module Parser.Final -( Dynamic(..) -, Eval(..) -, SQ(..) -, Symantics(..) -, TQ(..) -, TextSymantics(..) -, Typeable(..) -, fromDyn -, parseSingle -, parseStrict -, toDyn -, runBoth' -) where - -import qualified Control.Monad.Combinators.Expr as E -import qualified Data.Eq.Type as EQ -import qualified Text.Megaparsec as M + ( Dynamic (..), + Eval (..), + SQ (..), + Symantics (..), + TQ (..), + TextSymantics (..), + Typeable (..), + fromDyn, + parseSingle, + parseStrict, + toDyn, + runBoth', + ) +where import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..), deepseq) +import Control.DeepSeq (NFData (..), deepseq) import Control.Monad.Combinators (sepBy) +import qualified Control.Monad.Combinators.Expr as E import Data.Eq.Type ((:=)) +import qualified Data.Eq.Type as EQ import Data.Functor (void) import Data.Maybe (isJust) import Data.Text (Text, drop, dropEnd, pack, unpack) import Parser.Utils +import qualified Text.Megaparsec as M import Prelude hiding (drop) -- ======================================== @@ -44,12 +44,12 @@ import Prelude hiding (drop) -- ======================================== class Symantics repr where - eInt :: Integer -> repr Integer + eInt :: Integer -> repr Integer eBool :: Bool -> repr Bool - eAdd :: repr Integer -> repr Integer -> repr Integer - eSub :: repr Integer -> repr Integer -> repr Integer - eAnd :: repr Bool -> repr Bool -> repr Bool - eOr :: repr Bool -> repr Bool -> repr Bool + eAdd :: repr Integer -> repr Integer -> repr Integer + eSub :: repr Integer -> repr Integer -> repr Integer + eAnd :: repr Bool -> repr Bool -> repr Bool + eOr :: repr Bool -> repr Bool -> repr Bool class (Symantics repr) => TextSymantics repr where eText :: Text -> repr Text @@ -58,12 +58,12 @@ class (Symantics repr) => TextSymantics repr where newtype Eval a = Eval {runEval :: a} deriving (Eq, Show) instance Symantics Eval where - eInt = Eval + eInt = Eval eBool = Eval eAdd (Eval lhs) (Eval rhs) = Eval (lhs + rhs) eSub (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 eText = Eval @@ -74,35 +74,35 @@ instance TextSymantics Eval where -- ======================================== class Typeable repr where - pInt :: repr Integer + pInt :: repr Integer pBool :: repr Bool pText :: repr Text newtype TQ t = TQ {runTQ :: forall repr. Typeable repr => repr t} instance Typeable TQ where - pInt = TQ pInt + pInt = TQ pInt pBool = TQ pBool pText = TQ pText newtype AsInt a = AsInt (Maybe (a := Integer)) instance Typeable AsInt where - pInt = AsInt (Just EQ.refl) + pInt = AsInt (Just EQ.refl) pBool = AsInt Nothing pText = AsInt Nothing newtype AsBool a = AsBool (Maybe (a := Bool)) instance Typeable AsBool where - pInt = AsBool Nothing + pInt = AsBool Nothing pBool = AsBool (Just EQ.refl) pText = AsBool Nothing newtype AsText a = AsText (Maybe (a := Text)) instance Typeable AsText where - pInt = AsText Nothing + pInt = AsText Nothing pBool = AsText Nothing pText = AsText (Just EQ.refl) @@ -141,14 +141,14 @@ fromDyn (Dynamic t e) = case t of r' <- r pure $ EQ.coerce (EQ.lift r') e -asDyn - :: forall repr a - . TextSymantics repr - => IsDynamic a - => (repr a -> repr a -> repr a) - -> Dynamic repr - -> Dynamic repr - -> Maybe (Dynamic repr) +asDyn :: + forall repr a. + TextSymantics repr => + IsDynamic a => + (repr a -> repr a -> repr a) -> + Dynamic repr -> + Dynamic repr -> + Maybe (Dynamic repr) asDyn bin lhs rhs = do lhs' <- fromDyn lhs rhs' <- fromDyn rhs @@ -160,25 +160,27 @@ asDyn bin lhs rhs = do parseSingle :: forall repr. TextSymantics repr => Parser (Dynamic repr) parseSingle = expr >>= either offsetFail pure - where - offsetFail (offset, msg) = M.setOffset offset >> fail msg + where + offsetFail (offset, msg) = M.setOffset offset >> fail msg - expr = E.makeExprParser term - [ [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 - void $ symbol name - offset <- M.getOffset - pure $ \lhs rhs -> do - lhs' <- lhs - rhs' <- rhs - case asDyn bin lhs' rhs' of - Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`") - Just a -> pure a + binary name bin = E.InfixL do + void $ symbol name + offset <- M.getOffset + pure $ \lhs rhs -> do + lhs' <- lhs + rhs' <- rhs + case asDyn bin lhs' rhs' of + Nothing -> Left (offset, "Invalid operands for `" <> unpack name <> "`") + Just a -> pure a - term = parens expr <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean + term = parens expr <|> Right . toDyn <$> integer <|> Right . toDyn <$> boolean -- ======================================== -- Strict @@ -190,41 +192,42 @@ instance (NFData t) => NFData (Eval t) where instance NFData (Dynamic Eval) where rnf (Dynamic _ e) = e `seq` () -parseStrict - :: forall repr - . NFData (Dynamic repr) - => TextSymantics repr - => Parser (Dynamic repr) +parseStrict :: + forall repr. + NFData (Dynamic repr) => + TextSymantics repr => + Parser (Dynamic repr) parseStrict = 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 + 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 asDyn bin t t' of - Nothing -> fail $ "Invalid operands for `" <> show op <> "`" - Just a -> a `deepseq` expr a + 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 asDyn 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 + term :: Parser (Dynamic repr) + term = do + p <- M.option Nothing $ Just <$> symbol "(" + if isJust p + then (term >>= expr) <* symbol ")" + else toDyn <$> integer <|> toDyn <$> boolean -- ======================================== -- Pretty print @@ -233,12 +236,12 @@ parseStrict = term >>= expr newtype PPrint a = PPrint {runPPrint :: Text} deriving (Eq, Show) instance Symantics PPrint where - eInt = PPrint . pack . show + eInt = PPrint . pack . show eBool = PPrint . pack . show eAdd (PPrint lhs) (PPrint rhs) = PPrint $ "(" <> lhs <> " + " <> rhs <> ")" eSub (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 eText = PPrint @@ -265,22 +268,22 @@ instance MulSymantics PPrint where newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a} instance Symantics SQ where - eInt e = SQ (eInt e) + eInt e = SQ (eInt e) eBool e = SQ (eBool e) eAdd (SQ lhs) (SQ rhs) = SQ (eAdd lhs rhs) eSub (SQ lhs) (SQ rhs) = SQ (eSub 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} instance Symantics MSQ where - eInt e = MSQ (eInt e) + eInt e = MSQ (eInt e) eBool e = MSQ (eBool e) eAdd (MSQ lhs) (MSQ rhs) = MSQ (eAdd lhs rhs) eSub (MSQ lhs) (MSQ rhs) = MSQ (eSub 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 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) -instance (Symantics repr1, Symantics repr2) - => Symantics (SCopy repr1 repr2) where - eInt e = SCopy (eInt e) (eInt e) +instance + (Symantics repr1, Symantics repr2) => + Symantics (SCopy repr1 repr2) + where + eInt e = SCopy (eInt e) (eInt e) eBool e = SCopy (eBool e) (eBool e) 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) 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) - => MulSymantics (SCopy repr1 repr2) where +instance + (MulSymantics repr1, MulSymantics repr2) => + MulSymantics (SCopy repr1 repr2) + where eMul (SCopy a1 a2) (SCopy b1 b2) = SCopy (eMul a1 b1) (eMul a2 b2) -runEval' - :: forall repr - . Dynamic (SCopy Eval repr) - -> Maybe (Result, Dynamic repr) +runEval' :: + forall repr. + Dynamic (SCopy Eval repr) -> + Maybe (Result, Dynamic repr) runEval' d = case fromDyn d :: Maybe (SCopy Eval repr Integer) of Just (SCopy (Eval a) r) -> pure (RInt a, Dynamic pInt r) Nothing -> case fromDyn d :: Maybe (SCopy Eval repr Bool) of Just (SCopy (Eval a) r) -> pure (RBool a, Dynamic pBool r) Nothing -> Nothing -runPPrint' - :: forall repr - . Dynamic (SCopy PPrint repr) - -> Maybe (Text, Dynamic repr) +runPPrint' :: + forall repr. + Dynamic (SCopy PPrint repr) -> + Maybe (Text, Dynamic repr) runPPrint' d = case fromDyn d :: Maybe (SCopy PPrint repr Text) of Just (SCopy (PPrint a) r) -> pure (a, Dynamic pText r) Nothing -> Nothing -runBoth' - :: forall repr - . Dynamic (SCopy Eval (SCopy PPrint repr)) - -> Maybe (Result, Text, Dynamic repr) +runBoth' :: + forall repr. + Dynamic (SCopy Eval (SCopy PPrint repr)) -> + Maybe (Result, Text, Dynamic repr) runBoth' d = do (r, d') <- runEval' d (p, d'') <- runPPrint' d' diff --git a/tagless-final/test/Test/Parser/FinalTest.hs b/tagless-final/test/Test/Parser/FinalTest.hs index 835e3b7..c91b1c8 100644 --- a/tagless-final/test/Test/Parser/FinalTest.hs +++ b/tagless-final/test/Test/Parser/FinalTest.hs @@ -5,8 +5,9 @@ {-# LANGUAGE TypeApplications #-} module Test.Parser.FinalTest -( spec_parser, -) where + ( spec_parser, + ) +where import Data.Text (Text) import Parser.Final @@ -78,7 +79,9 @@ spec_parser = do shouldParse "false || false" (toDyn False) describe "invalid types" do it "mismatch" do - shouldNotParse "true && 1" + shouldNotParse + "true && 1" "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"