Move around and setup last exercise.

initial-encoding/app/Main.hs

@@ -40,7 +40,7 @@ run args = do
     "mem_cons" -> runExpr runMemCons contents
     "gadt"     -> case runGadt contents of
                     Left e -> print e
-                    Right (Wrapper a) -> print $ gadtEval a
+                    Right (Wrapper a) -> print $ evalGadt a
     _          -> error "Encountered an invalid parsing strategy."
 
 main :: IO ()

initial-encoding/src/Parser/Initial.hs

@@ -10,7 +10,7 @@ module Parser.Initial
 , GExpr(..)
 , Wrapper(..)
 , eval
-, gadtEval
+, evalGadt
 , runGadt
 , runMemCons
 , runMulPass
@@ -204,13 +204,13 @@ fromBool a@(GAnd  _ _) = pure a
 fromBool a@(GOr   _ _) = pure a
 fromBool _             = Left "Expected a boolean type."
 
-gadtEval :: GExpr a -> a
+evalGadt :: GExpr a -> a
-gadtEval (GInt a)  = a
+evalGadt (GInt a)  = a
-gadtEval (GBool a) = a
+evalGadt (GBool a) = a
-gadtEval (GAdd lhs rhs) = gadtEval lhs + gadtEval rhs
+evalGadt (GAdd lhs rhs) = evalGadt lhs + evalGadt rhs
-gadtEval (GSub lhs rhs) = gadtEval lhs - gadtEval rhs
+evalGadt (GSub lhs rhs) = evalGadt lhs - evalGadt rhs
-gadtEval (GAnd lhs rhs) = gadtEval lhs && gadtEval rhs
+evalGadt (GAnd lhs rhs) = evalGadt lhs && evalGadt rhs
-gadtEval (GOr lhs rhs)  = gadtEval lhs || gadtEval rhs
+evalGadt (GOr lhs rhs)  = evalGadt lhs || evalGadt rhs
 
 gadtExpr :: forall m. MonadError Text m => ParserT m Wrapper
 gadtExpr = term >>= expr
@@ -236,7 +236,7 @@ gadtExpr = term >>= expr
     Wrapper t' <- term
     case (cast t, cast t') of
       (Right lhs, Right rhs) -> do
-        let z = f . gadtEval $ bin lhs rhs
+        let z = f . evalGadt $ bin lhs rhs
         z `deepseq` expr (Wrapper z)
       (Left e, _) -> throwError e
       (_, Left e) -> throwError e

tagless-final/app/Main.hs

@@ -6,7 +6,7 @@ module Main where
 import Data.Text (Text)
 import Data.Text.IO (hGetContents)
 import Options.Applicative
-import Parser.Tagless.Closed
+import Parser.Final
 import System.Environment (getArgs)
 import System.IO (IOMode(ReadMode), openFile)
 

tagless-final/src/Parser/Final.hs

@@ -9,7 +9,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 
-module Parser.Tagless.Closed
+module Parser.Final
 ( Dynamic(..)
 , Eval(..)
 , SQ(..)
@@ -53,16 +53,6 @@ class Symantics repr where
   eAnd  :: repr Bool -> repr Bool -> repr Bool
   eOr   :: repr Bool -> repr Bool -> repr Bool
 
-newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
-
-instance Symantics SQ where
-  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)
-
 newtype Eval a = Eval {runEval :: a} deriving (Eq, Show)
 
 instance Symantics Eval where
@@ -231,3 +221,73 @@ runMemCons
 runMemCons input =
   let res = M.runParser (memConsExpr <* M.eof) "" input
    in first (pack . M.errorBundlePretty) res
+
+-- ========================================
+-- Printer
+-- ========================================
+
+newtype Print a = Print {runPrint :: Text} deriving (Eq, Show)
+
+instance Symantics Print where
+  eInt  = Print . pack . show
+  eBool = Print . pack . show
+  eAdd (Print lhs) (Print rhs) = Print ("(" <> lhs <> " + " <> rhs <> ")")
+  eSub (Print lhs) (Print rhs) = Print ("(" <> lhs <> " - " <> rhs <> ")")
+  eAnd (Print lhs) (Print rhs) = Print ("(" <> lhs <> " && " <> rhs <> ")")
+  eOr  (Print lhs) (Print rhs) = Print ("(" <> lhs <> " || " <> rhs <> ")")
+
+instance (NFData t) => NFData (Print t) where
+  rnf (Print t) = t `seq` ()
+
+instance NFData (Dynamic Print) where
+  rnf (Dynamic _ p) = p `seq` ()
+
+{-
+No instance for (IsDynamic Text)
+Couldn't match type `Eval` with `Print`
+
+evalStuck :: Text -> Either Text (Either Integer Bool, Text)
+evalStuck input = do
+  d <- runMemCons input
+  let e1 = fromDyn d :: Maybe (Eval Integer)
+  let e2 = fromDyn d :: Maybe (Eval Bool)
+  let e3 = fromDyn d :: Maybe (Print Text)
+  ...
+-}
+
+-- ========================================
+-- Closed
+-- ========================================
+
+newtype SQ a = SQ {runSQ :: forall repr. Symantics repr => repr a}
+
+instance Symantics SQ where
+  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)
+
+instance NFData (SQ t) where
+  rnf _ = ()
+
+instance NFData (Dynamic SQ) where
+  rnf (Dynamic _ _) = ()
+
+evalClosed :: Text -> Either Text (Either Integer Bool, Text)
+evalClosed input = do
+  d <- runMemCons input
+  let e1 = fromDyn d :: Maybe (SQ Integer)
+  let e2 = fromDyn d :: Maybe (SQ Bool)
+  case (e1, e2) of
+    (Just a, _) -> case runSQ a of
+       Eval e -> case runSQ a of Print b -> pure (Left e, b)
+    (_, Just a) -> case runSQ a of
+       Eval e -> case runSQ a of Print b -> pure (Right e, b)
+    _ -> Left "Could not cast into a integer or boolean."
+
+-- ========================================
+-- Open
+-- ========================================
+

tagless-final/tagless-final.cabal

@@ -23,7 +23,7 @@ library
                       text
   hs-source-dirs:     src
   default-language:   Haskell2010
-  exposed-modules:    Parser.Tagless.Closed
+  exposed-modules:    Parser.Final
 
 test-suite tagless-final-test
   type:               exitcode-stdio-1.0
@@ -39,4 +39,4 @@ test-suite tagless-final-test
                       tasty-discover,
                       tasty-hspec,
                       text
-  other-modules:      Test.Parser.Tagless.ClosedTest
+  other-modules:      Test.Parser.FinalTest

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

@@ -4,12 +4,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Test.Parser.Tagless.ClosedTest
+module Test.Parser.FinalTest
 ( spec_parser,
 ) where
 
 import Data.Text (Text)
-import Parser.Tagless.Closed
+import Parser.Final
 import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
 
 runParsers :: Text -> [Either Text (Dynamic Eval)]