{-# LANGUAGE ViewPatterns #-}

module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) where

import Graphics.Implicit.Definitions
import Graphics.Implicit.ExtOpenScad.Definitions
import Graphics.Implicit.ExtOpenScad.Util.OVal
import Graphics.Implicit.ExtOpenScad.Util.StateC

import qualified Data.Maybe as Maybe
import qualified Data.List as List
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Control.Monad as Monad
import qualified Control.Monad.State as State
import           Control.Monad.State (State,StateT, get, put, modify, liftIO)


patVars :: Pattern -> [String]
patVars (Name  name) = [name]
patVars (ListP pats) = concat $ map patVars pats
patVars _ = []

patMatch :: Pattern -> OVal -> Maybe [OVal]
patMatch (Name _) val = Just [val]
patMatch (ListP pats) (OList vals) = do
    matches <- Monad.zipWithM patMatch pats vals
    return $ concat matches
patMatch Wild _ = Just []
patMatch _ _ = Nothing

matchPat :: Pattern -> OVal -> Maybe VarLookup
matchPat pat val = do
    let vars = patVars pat
    vals <- patMatch pat val
    return $ Map.fromList $ zip vars vals


evalExpr :: Expr -> StateC OVal
evalExpr expr = do
    varlookup  <- getVarLookup
    (valf, _) <- liftIO $ State.runStateT (evalExpr' expr) (varlookup, [])
    return $ valf []



evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal)

evalExpr' (Var   name ) = do
    (varlookup, namestack) <- get
    return $
        case (Map.lookup name varlookup, List.findIndex (==name) namestack) of
            (_, Just pos) -> \s -> s !! pos
            (Just val, _) -> const val
            _             -> const $ OError ["Variable " ++ name ++ " not in scope" ]   

evalExpr' (LitE  val  ) = return $ const val

evalExpr' (ListE exprs) = do
    valFuncs <- Monad.mapM evalExpr' exprs
    return $ \s -> OList $ map ($s) valFuncs

evalExpr' (fexpr :$ argExprs) = do
    fValFunc <- evalExpr' fexpr
    argValFuncs <- Monad.mapM evalExpr' argExprs
    return $ \s -> app (fValFunc s) (map ($s) argValFuncs)
        where 
            app f l = case (getErrors f, getErrors $ OList l) of
                (Nothing, Nothing) -> app' f l where
                    app' (OFunc f) (x:xs) = app (f x) xs
                    app' a [] = a
                    app' x _ = OError ["Can't apply arguments to " ++ oTypeStr x]
                (Just err, _     ) -> OError [err]
                (_,      Just err) -> OError [err]

evalExpr' (LamE pats fexpr) = do
    fparts <- Monad.forM pats $ \pat -> do
        modify (\(vl, names) -> (vl, patVars pat ++ names))
        return $ \f xss -> OFunc $ \val -> case patMatch pat val of
            Just xs -> f (xs ++ xss)
            Nothing -> OError ["Pattern match failed"]
    fval <- evalExpr' fexpr
    return $ foldr ($) fval fparts


--------------


simplifyExpr ((simplifyExpr -> Var f) :$ args) = (Var f :$) $
    let
        split b l = (filter b l, filter (not.b) l)
        args' = map simplifyExpr args
        (numArgs, nonNumArgs) = split (\x -> case x of LitE (ONum n) -> True; _ -> False) args'
        numArgs' = map (\(LitE (ONum n)) -> n) numArgs
    in case f of
        "+" -> (LitE $ ONum $ sum  numArgs'):nonNumArgs
        "*" -> (LitE $ ONum $ product numArgs'):nonNumArgs
        _ -> args'
simplifyExpr x = x