fix errors (gen InputE 0 in patterns 1, more logs), split files

escher/Eval.hs

@@ -0,0 +1,122 @@
+module Eval where
+
+import Expr
+import Data.Map (Map)
+import qualified Data.Map.Lazy as Map
+import Control.Monad (foldM)
+
+import Debug.Trace (trace)
+
+type Oracle = [Value] -> Maybe Value
+
+data Conf = Conf {confInput :: [Value],
+                  confOracle :: Oracle,
+                  confExamples :: [[Value]]}
+
+-- TODO: check
+structuralLess :: Value -> Value -> Bool
+structuralLess (BoolV left) (BoolV right) = not left && right
+structuralLess (IntV left) (IntV right) = left < right && left > 0 -- ??
+-- TODO: require same elems ?
+structuralLess (ListV left) (ListV right) = length left < length right
+-- TODO: require subtree ?
+structuralLess (TreeV left) (TreeV right) = treeHeight left < treeHeight right
+structuralLess _ _ = False
+
+eval :: Conf -> Expr -> Result Value
+eval conf (left :&&: right) = do BoolV leftB <- eval conf left
+                                 BoolV rightB <- eval conf right
+                                 return $ BoolV $ leftB && rightB
+eval conf (left :||: right) = do BoolV leftB <- eval conf left
+                                 BoolV rightB <- eval conf right
+                                 return $ BoolV $ leftB || rightB
+eval conf (NotE e) = do BoolV b <- eval conf e
+                        return $ BoolV $ not b
+eval conf (left :=: right) = do leftV <- eval conf left
+                                rightV <- eval conf right
+                                return $ BoolV $ leftV == rightV
+eval conf (Leq0 e) = do IntV i <- eval conf e
+                        return $ BoolV $ i <= 0
+eval conf (IsEmptyE e) = do v <- eval conf e
+                            case v of
+                              ListV [] -> return $ BoolV True
+                              ListV _ -> return $ BoolV False
+                              _ -> FatalError $ "Can't take empty not from list" ++ show v
+eval conf (left :+: right) = do IntV leftI <- eval conf left
+                                IntV rightI <- eval conf right
+                                return $ IntV $ leftI + rightI
+eval conf (left :-: right) = do IntV leftI <- eval conf left
+                                IntV rightI <- eval conf right
+                                return $ IntV $ leftI - rightI
+eval conf (IncE e) = do IntV i <- eval conf e
+                        return $ IntV $ i + 1
+eval conf (DecE e) = do IntV i <- eval conf e
+                        return $ IntV $ i - 1
+eval conf ZeroE = return $ IntV 0
+eval conf (Div2E e) = do IntV i <- eval conf e
+                         return $ IntV $ i `div` 2
+eval conf (TailE e) = do ListV (_ : t) <- eval conf e
+                         return $ ListV t
+eval conf (HeadE e) = do ListV (h : _) <- eval conf e
+                         return h
+eval conf (left :++: right) = do ListV leftL <- eval conf left
+                                 ListV rightL <- eval conf right
+                                 return $ ListV $ leftL ++ rightL
+eval conf (left ::: right) = do leftV <- eval conf left
+                                ListV rightL <- eval conf right
+                                return $ ListV $ leftV : rightL
+eval conf EmptyListE = return $ ListV []
+eval conf (IsLeafE e) = do TreeV t <- eval conf e
+                           return $ BoolV $ case t of
+                             TNode {} ->  False
+                             TLeaf {} -> True
+eval conf (TreeValE e) = do TreeV t <- eval conf e
+                            return $ case t of
+                              n@TNode {}  -> treeRoot n
+                              TLeaf e -> e
+eval conf (TreeLeftE e) = do TreeV n@(TNode {}) <- eval conf e
+                             return $ TreeV $ treeLeft n
+eval conf (TreeRightE e) = do TreeV n@(TNode {}) <- eval conf e
+                              return $ TreeV $ treeRight n
+eval conf (CreateNodeE {nodeLeft, nodeRoot, nodeRight}) = do TreeV treeLeft <- eval conf nodeLeft
+                                                             treeRoot <- eval conf nodeRoot
+                                                             TreeV treeRight <- eval conf nodeRight
+                                                             return $ TreeV $ TNode { treeLeft, treeRoot, treeRight }
+eval conf (CreateLeafE e) = do v <- eval conf e
+                               return $ TreeV $ TLeaf v
+eval conf (IfE {ifCond, ifDoThen, ifDoElse}) = do BoolV condB <- eval conf ifCond
+                                                  if condB then eval conf ifDoThen else eval conf ifDoElse
+eval conf (SelfE es) = do recInput <- foldM (\es e -> consValsM es (eval conf e)) [] es
+                          -- NOTE: replaced guards for better errors description
+                          -- guard $ length newInput == length (confInput conf)
+                          -- guard $ and $ zipWith structuralLess newInput (confInput conf)
+                          if length recInput /= length (confInput conf)
+                          then FatalError $ "self call different length, new=" ++ show recInput ++ " old=" ++ show (confInput conf) -- TODO: fatal ?
+                          else do
+                            if not $ and $ zipWith structuralLess recInput (confInput conf)
+                            then RecError $ "self call on >= exprs, new=" ++ show recInput ++ " old=" ++ show (confInput conf)
+                            else do
+                              case confOracle conf recInput of
+                                  Just recOutput -> if recInput `elem` confExamples conf
+                                                    then return recOutput
+                                                    else NewExamples $ trace ("newExample: " ++ show [(recInput, recOutput)]) [(recInput, recOutput)]
+                                  Nothing -> FatalError $ "no oracle output on " ++ show recInput
+  where consValsM :: [Value] -> Result Value -> Result [Value]
+        consValsM vs (Result v) = Result $ v : vs
+        consValsM _ (FatalError err) = FatalError err
+        consValsM _ (RecError err) = RecError err
+        consValsM _ (NewExamples ex) = NewExamples ex
+eval conf (InputE i) = do if i < 0 || i >= length (confInput conf) -- NOTE: replaced guard for better errors description
+                          then FatalError $ "can't access input " ++ show (confInput conf) ++ " by id " ++ show i -- TODO: fatal ?
+                          else return $ confInput conf !! i -- use !? instead (?)
+eval _ Hole = FatalError "can't eval hole"
+
+
+type Cache = Map Expr (Result Value)
+
+eval' :: Cache -> Conf -> Expr -> (Result Value, Cache)
+eval' cache conf expr = case expr `Map.lookup` cache of
+                          Just result -> (result, cache)
+                          Nothing -> let result = eval conf expr in
+                                     (result, Map.insert expr result cache)
+