From 0aa1b1dbb05d2fde2c0550d0b17b682da1f1d015 Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Mon, 22 Jan 2018 20:05:18 -0500
Subject: [PATCH] More infrastructure work to add globals
---
app/Main.hs | 46 ++++++++++++++++--------------
src/Language/Lambda.hs | 12 ++++++--
src/Language/SystemF.hs | 11 +++++--
test/Language/Lambda/HspecUtils.hs | 3 +-
test/Language/LambdaSpec.hs | 11 +++----
5 files changed, 52 insertions(+), 31 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index fd999a1..615aabe 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -2,6 +2,8 @@ module Main where
import Data.Version
+import Control.Monad
+import Data.Bifunctor
import Data.Semigroup
import Options.Applicative hiding (ParseError)
import System.Console.Shell
@@ -40,32 +42,26 @@ data Globals n t
= GlobalsUntyped (Map.Map n (Lambda.LambdaExpr n))
| GlobalsSystemF (Map.Map n (SystemF.SystemFExpr n t))
+newGlobals :: Language -> Globals n t
+newGlobals Untyped = GlobalsUntyped Map.empty
+newGlobals SystemF = GlobalsSystemF Map.empty
+
-- | The result of an evaluation
type Result a state = Either a -- ^ An error
(a, state) -- ^ The result along with its state
-- | Represent a language together with its evaluation function
-data Eval a = Eval a (String -> Result String (Globals String String))
+data Eval a = Eval a (Globals String String -> String -> Result String (Globals String String))
untyped :: Eval Language
untyped = Eval Untyped eval
- where eval = fromEvalString Lambda.evalString
+ where eval (GlobalsUntyped g) s = bimap show toResult $ Lambda.evalString g s
+ toResult (e, g) = (prettyPrint e, GlobalsUntyped g)
systemf :: Eval Language
systemf = Eval SystemF eval
- where eval = fromEvalString SystemF.evalString
-
--- | Take a typed evaluation function and return a function that returns a result
---
--- For example:
--- (String -> Either ParseError (LambdaExpr String)) -> (String -> Result String)
--- (String -> Either ParseError (SystemFExpr String String)) -> (String -> Result String)
-fromEvalString :: (Show s, PrettyPrint p)
- => (String -> Either s p)
- -> (String -> Result String (Globals String String))
-fromEvalString f = either (Left . show) (Right . toResult) . f
- -- TODO[sgillespie]: Remove placeholder below
- where toResult expr = (prettyPrint expr, GlobalsUntyped Map.empty)
+ where eval (GlobalsSystemF g) s = bimap show toResult $ SystemF.evalString g s
+ toResult (e, g) = (prettyPrint e, GlobalsSystemF g)
cliParser :: Parser CliOptions
cliParser = CliOptions
@@ -82,11 +78,11 @@ cliParser = CliOptions
runShell' :: CliOptions -> IO ()
runShell' CliOptions{version=True} = putStrLn version'
runShell' CliOptions{language=Eval lang eval}
- = runShell (mkShellDesc lang eval) haskelineBackend ()
+ = void $ runShell (mkShellDesc lang eval) haskelineBackend (newGlobals lang)
mkShellDesc :: Language
- -> (String -> Result String (Globals String String))
- -> ShellDescription ()
+ -> (Globals String String -> String -> Result String (Globals String String))
+ -> ShellDescription (Globals String String)
mkShellDesc language f = shellDesc' $ mkShellDescription commands (eval f)
where shellDesc' d = d {
greetingText = Just shellGreeting,
@@ -107,10 +103,18 @@ commands = [
helpCommand "h"
]
-eval :: (String -> Result String (Globals String String)) -> String -> Sh s' ()
-eval f = either shellPutErrLn shellPutStrLn . fmap fst . f
+eval :: (Globals String String -> String -> Result String (Globals String String))
+ -> String
+ -> Sh (Globals String String) ()
+eval f str = do
+ globals <- getShellSt
+
+ case f globals str of
+ Left err -> shellPutErrLn err
+ Right (result, globals') -> do
+ putShellSt globals'
+ shellPutStr result
-- | Get the current version
version' :: String
version' = showVersion P.version
-
diff --git a/src/Language/Lambda.hs b/src/Language/Lambda.hs
index 2b58dd3..3ba7d4d 100644
--- a/src/Language/Lambda.hs
+++ b/src/Language/Lambda.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
module Language.Lambda (
+ Globals(..),
LambdaExpr(..),
ParseError(..),
PrettyPrint(..),
@@ -12,13 +13,20 @@ module Language.Lambda (
import Control.Monad
import Text.Parsec
+import qualified Data.Map as Map
+
import Language.Lambda.Eval
import Language.Lambda.Expression
import Language.Lambda.Parser
import Language.Lambda.Util.PrettyPrint
-evalString :: String -> Either ParseError (LambdaExpr String)
-evalString = fmap (evalExpr uniques) . parseExpr
+type Globals = Map.Map String (LambdaExpr String)
+
+evalString :: Globals
+ -> String
+ -> Either ParseError (LambdaExpr String, Globals)
+evalString globals str = flip (,) globals <$> eval'
+ where eval' = evalExpr uniques <$> parseExpr str
uniques :: [String]
uniques = concatMap (\p -> map (:p) . reverse $ ['a'..'z']) suffix
diff --git a/src/Language/SystemF.hs b/src/Language/SystemF.hs
index 422ef14..634f354 100644
--- a/src/Language/SystemF.hs
+++ b/src/Language/SystemF.hs
@@ -1,4 +1,5 @@
module Language.SystemF (
+ Globals(..),
PrettyPrint(..),
SystemFExpr(..),
evalString,
@@ -7,10 +8,16 @@ module Language.SystemF (
import Text.Parsec
+import qualified Data.Map as Map
+
import Language.Lambda.Util.PrettyPrint
import Language.SystemF.Expression
import Language.SystemF.Parser
-evalString :: String -> Either ParseError (SystemFExpr String String)
-evalString = parseExpr
+type Globals = Map.Map String (SystemFExpr String String)
+
+evalString :: Globals
+ -> String
+ -> Either ParseError (SystemFExpr String String, Globals)
+evalString globals = fmap (flip (,) globals) . parseExpr
diff --git a/test/Language/Lambda/HspecUtils.hs b/test/Language/Lambda/HspecUtils.hs
index dd41638..c9927ef 100644
--- a/test/Language/Lambda/HspecUtils.hs
+++ b/test/Language/Lambda/HspecUtils.hs
@@ -1,5 +1,6 @@
module Language.Lambda.HspecUtils where
+import Data.Map (empty)
import Test.Hspec
import Language.Lambda
@@ -8,4 +9,4 @@ shouldEvalTo :: String -> String -> Expectation
shouldEvalTo s1 = shouldBe (eval s1) . eval
eval :: String -> Either ParseError (LambdaExpr String)
-eval = evalString
+eval = fmap fst . evalString empty
diff --git a/test/Language/LambdaSpec.hs b/test/Language/LambdaSpec.hs
index 44cc67c..13265e9 100644
--- a/test/Language/LambdaSpec.hs
+++ b/test/Language/LambdaSpec.hs
@@ -3,20 +3,21 @@ module Language.LambdaSpec where
import Test.Hspec
import Language.Lambda
+import Language.Lambda.HspecUtils
spec :: Spec
spec = do
describe "evalString" $ do
it "evaluates simple strings" $ do
- evalString "x" `shouldBe` Right (Var "x")
- evalString "\\x. x" `shouldBe` Right (Abs "x" (Var "x"))
- evalString "f y" `shouldBe` Right (App (Var "f") (Var "y"))
+ eval "x" `shouldBe` Right (Var "x")
+ eval "\\x. x" `shouldBe` Right (Abs "x" (Var "x"))
+ eval "f y" `shouldBe` Right (App (Var "f") (Var "y"))
it "reduces simple applications" $
- evalString "(\\x .x) y" `shouldBe` Right (Var "y")
+ eval "(\\x .x) y" `shouldBe` Right (Var "y")
it "reduces applications with nested redexes" $
- evalString "(\\f x. f x) (\\y. y)" `shouldBe` Right (Abs "x" (Var "x"))
+ eval "(\\f x. f x) (\\y. y)" `shouldBe` Right (Abs "x" (Var "x"))
describe "uniques" $ do
let alphabet = reverse ['a'..'z']
--
GitLab