Automatic formatting.

.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;

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/
+```

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
           ];
         };

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
+args =
-  <$> O.strArgument
+  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.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
   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
+    "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 = 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"
+        )

initial-encoding/src/Parser/Initial.hs

@@ -6,48 +6,48 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 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.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
+  | EAdd Expr Expr
-  | ESub  Expr Expr
+  | ESub Expr Expr
-  | EAnd  Expr Expr
+  | EAnd Expr Expr
-  | EOr   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
+  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
@@ -100,20 +102,22 @@ parseNaive = expr >>= either (fail . unpack) pure . toResult
 
 parseSingle :: Parser Result
 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
@@ -125,100 +129,102 @@ instance NFData Result where
 
 parseStrict :: Parser Result
 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
 -- ========================================
 
 data GExpr a where
-  GInt  :: Integer -> GExpr Integer
+  GInt :: Integer -> GExpr Integer
   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)
 
 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@(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 = 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

initial-encoding/test/Test/Parser/InitialTest.hs

@@ -4,41 +4,42 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Test.Parser.InitialTest
-( spec_parser,
+  ( spec_parser,
-) where
+  )
-
+where
-import qualified Text.Megaparsec as M
 
 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 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
@@ -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"

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
+  (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 = putStrLn "Hello, Haskell!"

parser-utils/src/Parser/Utils.hs

@@ -2,28 +2,28 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 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 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
+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 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)

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
+args =
-  <$> O.strArgument
+  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.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
     "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
+  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"
+        )

tagless-final/src/Parser/Final.hs

@@ -11,32 +11,32 @@
 {-# LANGUAGE ViewPatterns #-}
 
 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.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
+  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
   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
+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
   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
+  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
@@ -190,41 +192,42 @@ instance (NFData t) => NFData (Eval t) where
 instance NFData (Dynamic Eval) where
   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
- 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
@@ -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)
+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)
   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)
+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)
 
-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
   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'
+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
   Just (SCopy (PPrint a) r) -> pure (a, Dynamic pText r)
   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
   (r, d') <- runEval' d
   (p, d'') <- runPPrint' d'

tagless-final/test/Test/Parser/FinalTest.hs

@@ -5,8 +5,9 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Parser.FinalTest
-( spec_parser,
+  ( spec_parser,
-) where
+  )
+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"