Fakultas Ilmu Komputer UI

Commit 0aa1b1db authored by Sean Gillespie's avatar Sean Gillespie
Browse files

More infrastructure work to add globals

parent cba6a55d
......@@ -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
{-# 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
......
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
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
......@@ -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']
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment