From 4fadf4bc0192108eecba721c41e5f40ab822b3a2 Mon Sep 17 00:00:00 2001
From: milner <m@cpl0.zip>
Date: Mon, 27 Jan 2020 12:00:00 +0000
Subject: [PATCH] evaluate source matches with ordered clause semantics

---
 src/Tessera/Eval.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 173 insertions(+)
 create mode 100644 src/Tessera/Eval.hs

diff --git a/src/Tessera/Eval.hs b/src/Tessera/Eval.hs
new file mode 100644
index 0000000..0df46db
--- /dev/null
+++ b/src/Tessera/Eval.hs
@@ -0,0 +1,173 @@
+module Tessera.Eval where
+
+import Data.List (foldl')
+import qualified Data.Map.Strict as Map
+
+import Tessera.Env
+import Tessera.Matrix (Key (..))
+import Tessera.Syntax
+import Tessera.Tree
+
+data Value
+  = VInt Integer
+  | VBool Bool
+  | VCon String [Value]
+  | VTuple [Value]
+  deriving (Eq, Show)
+
+renderValue :: Value -> String
+renderValue value = case value of
+  VInt n -> show n
+  VBool b -> if b then "True" else "False"
+  VCon name [] -> name
+  VCon name arguments -> name ++ " " ++ unwords (map renderAtom arguments)
+  VTuple elements -> "(" ++ joinComma (map renderValue elements) ++ ")"
+  where
+    renderAtom item = case item of
+      VCon _ (_ : _) -> "(" ++ renderValue item ++ ")"
+      VTuple _ -> "(" ++ renderValue item ++ ")"
+      _ -> renderValue item
+
+joinComma :: [String] -> String
+joinComma [] = ""
+joinComma [x] = x
+joinComma (x : rest) = x ++ ", " ++ joinComma rest
+
+matchPattern :: Pattern -> Value -> Maybe (Map.Map String Value)
+matchPattern pattern' value = case pattern' of
+  PWild -> Just Map.empty
+  PVar name -> Just (Map.singleton name value)
+  PInt n -> case value of
+    VInt m | n == m -> Just Map.empty
+    _ -> Nothing
+  PBool b -> case value of
+    VBool c | b == c -> Just Map.empty
+    _ -> Nothing
+  PTuple patterns -> case value of
+    VTuple values | length patterns == length values -> combine (zipWith matchPattern patterns values)
+    _ -> Nothing
+  PCon name patterns -> case value of
+    VCon name' values | name == name' && length patterns == length values -> combine (zipWith matchPattern patterns values)
+    _ -> Nothing
+  where
+    combine = foldl' step (Just Map.empty)
+    step Nothing _ = Nothing
+    step (Just acc) result = case result of
+      Nothing -> Nothing
+      Just extra -> Just (Map.union acc extra)
+
+matchClause :: [Pattern] -> [Value] -> Maybe (Map.Map String Value)
+matchClause patterns values
+  | length patterns /= length values = Nothing
+  | otherwise = foldl' step (Just Map.empty) (zipWith matchPattern patterns values)
+  where
+    step (Just acc) result = case result of
+      Nothing -> Nothing
+      Just extra -> Just (Map.union acc extra)
+    step Nothing _ = Nothing
+
+sourceSelect :: [[Pattern]] -> [Value] -> Maybe Int
+sourceSelect patternsList values =
+  case [i | (i, patterns) <- zip [0 ..] patternsList, matchClause patterns values /= Nothing] of
+    (i : _) -> Just i
+    [] -> Nothing
+
+valueKey :: Value -> Key
+valueKey value = case value of
+  VInt n -> KeyInt n
+  VBool b -> KeyBool b
+  VCon name _ -> KeyCon name
+  VTuple elements -> KeyTuple (length elements)
+
+lookupPath :: [Int] -> [Value] -> Maybe Value
+lookupPath [] _ = Nothing
+lookupPath (index : rest) values = case drop index values of
+  (value : _) -> navigate rest value
+  [] -> Nothing
+  where
+    navigate [] value = Just value
+    navigate (j : js) (VCon _ values') = if j < length values' then navigate js (values' !! j) else Nothing
+    navigate (j : js) (VTuple values') = if j < length values' then navigate js (values' !! j) else Nothing
+    navigate _ _ = Nothing
+
+runTree :: Tree -> [Value] -> Maybe Int
+runTree tree values = case tree of
+  Success index -> Just index
+  Failure -> Nothing
+  Bind _ _ inner -> runTree inner values
+  Switch occurrence branches fallback ->
+    let chosen = case lookupPath (occurrencePath occurrence) values of
+          Just value -> lookup (valueKey value) branches
+          Nothing -> Nothing
+    in case chosen of
+      Just branch -> runTree branch values
+      Nothing -> case fallback of
+        Just branch -> runTree branch values
+        Nothing -> Nothing
+
+evalExpr :: Env -> Map.Map String Value -> Expr -> Either String Value
+evalExpr env bindings expression = case expression of
+  EVar name -> case Map.lookup name bindings of
+    Just value -> Right value
+    Nothing -> Left ("unbound variable " ++ name)
+  EInt n -> Right (VInt n)
+  EBool b -> Right (VBool b)
+  ECon name arguments -> VCon name <$> mapM (evalExpr env bindings) arguments
+  ETuple elements -> VTuple <$> mapM (evalExpr env bindings) elements
+  EBin operator left right -> do
+    leftValue <- evalExpr env bindings left
+    rightValue <- evalExpr env bindings right
+    applyOperator operator leftValue rightValue
+  EIf condition yes no -> do
+    conditionValue <- evalExpr env bindings condition
+    case conditionValue of
+      VBool True -> evalExpr env bindings yes
+      VBool False -> evalExpr env bindings no
+      _ -> Left "condition is not a boolean"
+
+applyOperator :: Op -> Value -> Value -> Either String Value
+applyOperator operator left right = case operator of
+  OpAdd -> arithmetic (+) left right
+  OpSub -> arithmetic (-) left right
+  OpMul -> arithmetic (*) left right
+  OpDiv -> case (left, right) of
+    (VInt a, VInt b) | b /= 0 -> Right (VInt (a `div` b))
+    (VInt _, VInt _) -> Left "division by zero"
+    _ -> Left "arithmetic expects integers"
+  OpMod -> case (left, right) of
+    (VInt a, VInt b) | b /= 0 -> Right (VInt (a `mod` b))
+    (VInt _, VInt _) -> Left "modulo by zero"
+    _ -> Left "arithmetic expects integers"
+  OpEq -> Right (VBool (left == right))
+  OpNe -> Right (VBool (left /= right))
+  OpLt -> comparison (<) left right
+  OpLe -> comparison (<=) left right
+  OpGt -> comparison (>) left right
+  OpGe -> comparison (>=) left right
+  OpAnd -> logical (&&) left right
+  OpOr -> logical (||) left right
+  where
+    arithmetic f (VInt a) (VInt b) = Right (VInt (f a b))
+    arithmetic _ _ _ = Left "arithmetic expects integers"
+    comparison f (VInt a) (VInt b) = Right (VBool (f a b))
+    comparison _ _ _ = Left "comparison expects integers"
+    logical f (VBool a) (VBool b) = Right (VBool (f a b))
+    logical _ _ _ = Left "logical operators expect booleans"
+
+evaluateCompiled :: Env -> [Clause] -> Tree -> [Value] -> Either String Value
+evaluateCompiled env clauses tree values = case runTree tree values of
+  Nothing -> Left "no clause matched"
+  Just index -> case drop index clauses of
+    (clause : _) -> case matchClause (clausePatterns clause) values of
+      Nothing -> Left "internal binding failure"
+      Just bindings -> evalExpr env bindings (clauseBody clause)
+    [] -> Left "clause index out of range"
+
+evaluateSource :: Env -> [Clause] -> [Value] -> Either String Value
+evaluateSource env clauses values = case sourceSelect (map clausePatterns clauses) values of
+  Nothing -> Left "no clause matched"
+  Just index -> case drop index clauses of
+    (clause : _) -> case matchClause (clausePatterns clause) values of
+      Nothing -> Left "internal binding failure"
+      Just bindings -> evalExpr env bindings (clauseBody clause)
+    [] -> Left "clause index out of range"