diff --git a/initial-encoding/app/Main.hs b/initial-encoding/app/Main.hs index 3ee8d49..dd8a608 100644 --- a/initial-encoding/app/Main.hs +++ b/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 () diff --git a/initial-encoding/src/Parser/Initial.hs b/initial-encoding/src/Parser/Initial.hs index 53f7d4b..be8ff79 100644 --- a/initial-encoding/src/Parser/Initial.hs +++ b/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 -gadtEval (GInt a) = a -gadtEval (GBool a) = a -gadtEval (GAdd lhs rhs) = gadtEval lhs + gadtEval rhs -gadtEval (GSub lhs rhs) = gadtEval lhs - gadtEval rhs -gadtEval (GAnd lhs rhs) = gadtEval lhs && gadtEval rhs -gadtEval (GOr lhs rhs) = gadtEval lhs || gadtEval rhs +evalGadt :: GExpr a -> a +evalGadt (GInt a) = a +evalGadt (GBool a) = a +evalGadt (GAdd lhs rhs) = evalGadt lhs + evalGadt rhs +evalGadt (GSub lhs rhs) = evalGadt lhs - evalGadt rhs +evalGadt (GAnd lhs rhs) = evalGadt lhs && evalGadt 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 diff --git a/tagless-final/app/Main.hs b/tagless-final/app/Main.hs index 293a9fb..91cbd30 100644 --- a/tagless-final/app/Main.hs +++ b/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) diff --git a/tagless-final/src/Parser/Tagless/Closed.hs b/tagless-final/src/Parser/Final.hs similarity index 77% rename from tagless-final/src/Parser/Tagless/Closed.hs rename to tagless-final/src/Parser/Final.hs index 314a3bd..a2a32d7 100644 --- a/tagless-final/src/Parser/Tagless/Closed.hs +++ b/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 +-- ======================================== + diff --git a/tagless-final/tagless-final.cabal b/tagless-final/tagless-final.cabal index e1596e5..92e6d70 100644 --- a/tagless-final/tagless-final.cabal +++ b/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 diff --git a/tagless-final/test/Test/Parser/Tagless/ClosedTest.hs b/tagless-final/test/Test/Parser/FinalTest.hs similarity index 97% rename from tagless-final/test/Test/Parser/Tagless/ClosedTest.hs rename to tagless-final/test/Test/Parser/FinalTest.hs index 1e15915..b6dbda8 100644 --- a/tagless-final/test/Test/Parser/Tagless/ClosedTest.hs +++ b/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)]