diff options
Diffstat (limited to 'lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs')
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs | 37 |
1 files changed, 28 insertions, 9 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs index 324c881..104fddc 100644 --- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs +++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs @@ -8,6 +8,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.String (IsString (..)) import Data.Text (Text, pack) +import qualified Data.Text as Text import GHC.Generics (Generic) data Term @@ -15,6 +16,7 @@ data Term | Lam Text Term | App Term Term | Num Int + | Str Text deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) instance IsString Term where @@ -27,10 +29,11 @@ data Value = Clos EnvValue Text Term | VNeut Neutral | VNum Int + | VStr Text | Builtin Text Int [Value] deriving (Show, Read, Eq) -data Neutral = NVar Text | NNum Int | NApp Neutral Value +data Neutral = NVar Text | NNum Int | NStr Text | NApp Neutral Value deriving (Show, Read, Eq) type Env = [(Text, Term)] @@ -43,14 +46,19 @@ newEnv = [] -- | Arity table for every built-in operator. builtinArity :: Map Text Int builtinArity = Map.fromList - [ ("+", 2) - , ("-", 2) - , ("*", 2) - , ("div", 2) - , ("mod", 2) - , ("=", 2) - , ("<", 2) - , ("neg", 1) + [ ("+", 2) + , ("-", 2) + , ("*", 2) + , ("div", 2) + , ("mod", 2) + , ("=", 2) + , ("<", 2) + , ("neg", 1) + , ("str-concat", 2) + , ("str-length", 1) + , ("str-slice", 3) + , ("str=", 2) + , ("str<", 2) ] -- | The set of built-in names, for fast membership testing. @@ -77,6 +85,7 @@ eval env = \case a' = eval env a in f' `seq` a' `seq` apply f' a' Num n -> VNum n + Str s -> VStr s apply :: Value -> Value -> Value apply f a = @@ -86,6 +95,7 @@ apply f a = in eval env' body VNeut f' -> VNeut (NApp f' a) VNum n -> VNeut (NApp (NNum n) a) + VStr s -> VNeut (NApp (NStr s) a) -- Last argument arrives: dispatch and reduce. Builtin name 1 args -> dispatchBuiltin name (args ++ [a]) -- Still waiting for more arguments: accumulate. @@ -105,6 +115,7 @@ churchFalse = Clos builtinEnvValue "f" (Lam "t" (Var "f")) -- Comparison operators (= and <) return Church booleans rather than integers. dispatchBuiltin :: Text -> [Value] -> Value dispatchBuiltin name args = case (name, args) of + -- Integer arithmetic ("+", [VNum x, VNum y]) -> VNum (x + y) ("-", [VNum x, VNum y]) -> VNum (x - y) ("*", [VNum x, VNum y]) -> VNum (x * y) @@ -115,6 +126,12 @@ dispatchBuiltin name args = case (name, args) of ("=", [VNum x, VNum y]) -> if x == y then churchTrue else churchFalse ("<", [VNum x, VNum y]) -> if x < y then churchTrue else churchFalse ("neg", [VNum x]) -> VNum (negate x) + -- String operations + ("str-concat", [VStr x, VStr y]) -> VStr (x <> y) + ("str-length", [VStr x]) -> VNum (Text.length x) + ("str-slice", [VNum i, VNum j, VStr x]) -> VStr (Text.take (j - i) (Text.drop i x)) + ("str=", [VStr x, VStr y]) -> if x == y then churchTrue else churchFalse + ("str<", [VStr x, VStr y]) -> if x < y then churchTrue else churchFalse -- Stuck: reconstruct a neutral application chain rooted at the builtin name. _ -> foldl (\acc v -> VNeut (NApp (neutralOf acc) v)) (VNeut (NVar name)) args where @@ -132,8 +149,10 @@ readBack = go [] in Lam name (go names' val') VNeut (NVar n) -> Var n VNeut (NNum n) -> Num n + VNeut (NStr s) -> Str s VNeut (NApp f a) -> App (go names (VNeut f)) (go names a) VNum n -> Num n + VStr s -> Str s -- A partial builtin reads back as a chain of applications rooted at -- the builtin name, e.g. Builtin "+" 1 [VNum 3] → App (Var "+") (Num 3) Builtin bname _ accumulated -> |