1
Fork 0

Move around and setup last exercise.

jrpotter/final
Joshua Potter 2021-12-24 08:16:06 -05:00
parent cef32ad12b
commit 25ec417287
6 changed files with 86 additions and 26 deletions

View File

@ -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 ()

View File

@ -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

View File

@ -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)

View File

@ -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
-- ========================================

View File

@ -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

View File

@ -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)]