{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE MultiWayIf    #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns  #-}

{- |
Module      : Language.Egison.Core
Licence     : MIT

This module implements Phase 10: Evaluation.
It provides functions to evaluate expressions and perform pattern matching.

Evaluation Phase (Phase 10):
  - Pattern matching execution (patternMatch function)
    * Egison's powerful non-linear pattern matching with backtracking
    * Pattern matching is NOT desugared but executed during evaluation
  - Expression evaluation (evalExprShallow, evalExprDeep)
  - IO action execution
  - WHNF (Weak Head Normal Form) evaluation

Design Note (design/implementation.md):
Pattern matching is processed during evaluation, not during desugaring.
This allows Egison's sophisticated pattern matching features to be implemented
directly in the evaluator, keeping the desugaring phase simple.
-}

module Language.Egison.Core
    (
    -- * Evaluation
      evalExprShallow
    , evalExprDeep
    , evalWHNF
    -- * Type utilities
    , valueToType
    , whnfToType
    -- * Environment
    , recursiveBind
    , recursiveBindPatFuncs
    , recursiveBindAll
    , makeBindings'
    -- * Pattern matching
    , patternMatch
    ) where

import           Prelude                         hiding (mapM, mappend, mconcat)

import           Control.Arrow
import           Control.Monad                   (forM_, when, zipWithM, (>=>))
import           Control.Monad.Except            (throwError)
import           Control.Monad.State
import           Control.Monad.Trans.Maybe

import           Data.Char                       (isUpper)
import           Data.Foldable                   (toList)
import           Data.IORef
import           Data.List                       (partition)
import           Data.Maybe
import qualified Data.Sequence                   as Sq
import           Data.Traversable                (mapM)

import qualified Data.HashMap.Lazy               as HL
import qualified Data.HashMap.Strict             as HashMap
import qualified Data.Vector                     as V
import           Data.Text                       (Text)
import qualified Data.Text                       as T

import           Language.Egison.Data
import           Language.Egison.Data.Collection
import           Language.Egison.Data.Utils
import           Language.Egison.EvalState       (MonadEval (..), mLabelFuncName)
import           Language.Egison.IExpr
import           Language.Egison.MList
import           Language.Egison.Match
import           Language.Egison.Math
import           Language.Egison.RState
import           Language.Egison.Tensor
import           Language.Egison.Type.Types      (Type(..))

-- | Get the Type of an EgisonValue
-- Used for type class method dispatch
valueToType :: EgisonValue -> Type
valueToType (Bool _)         = TBool
valueToType (ScalarData (Div (Plus []) (Plus [Term 1 []])))          = TInt
valueToType (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = TInt
valueToType (ScalarData _)   = TInt  -- MathExpr = TInt in Egison
valueToType (Float _)        = TFloat
valueToType (Char _)         = TChar
valueToType (String _)       = TString
valueToType (Collection _)   = TCollection TAny  -- TODO: infer element type
valueToType (Tuple vs)       = TTuple (map valueToType vs)
valueToType (IntHash _)      = THash TInt TAny
valueToType (CharHash _)     = THash TChar TAny
valueToType (StrHash _)      = THash TString TAny
valueToType (TensorData _)   = TTensor TAny
valueToType (InductiveData name _) = TInductive name []  -- TODO: infer type args
valueToType _                = TAny

-- | Get the Type of a WHNFData
-- This extracts type information from WHNF without fully evaluating
whnfToType :: WHNFData -> Type
whnfToType (Value val) = valueToType val
whnfToType (IInductiveData name _) = TInductive name []
whnfToType (ITuple refs) = TTuple (replicate (length refs) TAny)  -- Can't know element types without evaluation
whnfToType (ICollection _) = TCollection TAny
whnfToType (IIntHash _) = THash TInt TAny
whnfToType (ICharHash _) = THash TChar TAny
whnfToType (IStrHash _) = THash TString TAny
whnfToType (ITensor _) = TTensor TAny

evalConstant :: ConstantExpr -> EgisonValue
evalConstant (CharExpr c)    = Char c
evalConstant (StringExpr s)  = toEgison s
evalConstant (BoolExpr b)    = Bool b
evalConstant (IntegerExpr x) = toEgison x
evalConstant (FloatExpr x)   = Float x
evalConstant SomethingExpr   = Something
evalConstant UndefinedExpr   = Undefined

--
-- IExpr Evaluation
--

evalExprShallow :: Env -> IExpr -> EvalM WHNFData
evalExprShallow _ (IConstantExpr c) = return $ Value (evalConstant c)

evalExprShallow env (IQuoteExpr expr) = do
  whnf <- evalExprShallow env expr
  case whnf of
    Value (ScalarData s) -> return . Value . ScalarData $ SingleTerm 1 [(Quote s, 1)]
    _                    -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf)

evalExprShallow env (IQuoteSymbolExpr expr) =
  case expr of
    IVarExpr name -> do
      -- Try to evaluate the variable
      case refVar env (stringToVar name) of
        Just ref -> do
          val <- evalRef ref
          case val of
            Value func@(Func _ _ _ _) -> 
              -- Quote the function object itself
              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]
            Value func@(MemoizedFunc _ _ _ _) -> 
              -- Quote the memoized function object itself
              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]
            Value (ScalarData _) -> return val
            _ -> return . Value $ symbolScalarData "" name
        Nothing -> return . Value $ symbolScalarData "" name
    _ -> do
      whnf <- evalExprShallow env expr
      case whnf of
        Value (ScalarData _) -> return whnf
        _                    -> throwErrorWithTrace (TypeMismatch "scalar or symbol in quote-symbol" whnf)

evalExprShallow env (IVarExpr name) =
  case refVar env (Var name []) of
    Nothing | isUpper (head name) ->
      return $ Value (InductiveData name [])
    Nothing  -> return $ Value (symbolScalarData "" name)
    Just ref -> evalRef ref

evalExprShallow _ (ITupleExpr []) = return . Value $ Tuple []  -- Unit value ()
evalExprShallow env (ITupleExpr [expr]) = evalExprShallow env expr
evalExprShallow env (ITupleExpr exprs) = ITuple <$> mapM (newThunkRef env) exprs

evalExprShallow _ (ICollectionExpr []) = return . Value $ Collection Sq.empty

evalExprShallow env (ICollectionExpr inners) = do
  inners' <- mapM ((IElement <$>) . newThunkRef env) inners
  innersSeq <- liftIO $ newIORef $ Sq.fromList inners'
  return $ ICollection innersSeq

evalExprShallow env (IConsExpr x xs) = do
  x' <- newThunkRef env x
  xs' <- newThunkRef env xs
  innersSeq <- liftIO $ newIORef $ Sq.fromList [IElement x', ISubCollection xs']
  return $ ICollection innersSeq

evalExprShallow env (IJoinExpr xs ys) = do
  xs' <- newThunkRef env xs
  ys' <- newThunkRef env ys
  innersSeq <- liftIO $ newIORef $ Sq.fromList [ISubCollection xs', ISubCollection ys']
  return $ ICollection innersSeq

evalExprShallow env (IVectorExpr exprs) = do
  let n = toInteger (length exprs)
  whnfs <- mapM (evalExprShallow env) exprs
  case whnfs of
    ITensor Tensor{}:_ ->
      mapM f whnfs >>= tConcat' >>= fromTensor
    _ -> makeITensorFromWHNF [n] whnfs
  where
    f (ITensor (Tensor ns xs indices)) = do
      xs' <- mapM evalRef xs
      xs'' <- mapM newEvaluatedObjectRef xs'
      return $ Tensor ns xs'' indices
    f x = Scalar <$> newEvaluatedObjectRef x

evalExprShallow env (ITensorExpr nsExpr xsExpr) = do
  nsWhnf <- evalExprShallow env nsExpr
  ns <- (collectionToRefs nsWhnf >>= fromMList >>= mapM evalRefDeep >>= mapM fromEgison) :: EvalM [Integer]
  xsWhnf <- evalExprShallow env xsExpr
  xs <- collectionToRefs xsWhnf >>= fromMList >>= mapM evalRef
  if product ns == toInteger (length xs)
    then makeITensorFromWHNF ns xs
    else throwErrorWithTrace InconsistentTensorShape

evalExprShallow env (IHashExpr assocs) = do
  let (keyExprs, exprs) = unzip assocs
  keyWhnfs <- mapM (evalExprShallow env) keyExprs
  keys <- mapM makeHashKey keyWhnfs
  refs <- mapM (newThunkRef env) exprs
  case keys of
    CharKey _ : _ -> do
      let keys' = map (\case CharKey c -> c) keys
      return . ICharHash $ HL.fromList $ zip keys' refs
    StrKey _ : _ -> do
      let keys' = map (\case StrKey s -> s) keys
      return . IStrHash $ HL.fromList $ zip keys' refs
    _ -> do
      let keys' = map (\case IntKey i -> i) keys
      return . IIntHash $ HL.fromList $ zip keys' refs
 where
  makeHashKey :: WHNFData -> EvalM EgisonHashKey
  makeHashKey (Value val) =
    case val of
      ScalarData _ -> IntKey <$> fromEgison val
      Char c       -> return (CharKey c)
      String str   -> return (StrKey str)
      _            -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val))
  makeHashKey whnf = throwErrorWithTrace (TypeMismatch "integer or string" whnf)

evalExprShallow env@(Env _fs _ _) (IIndexedExpr override expr indices) = do
  -- Tensor or hash
  whnf <- case expr of
              IVarExpr v -> do
                let mObjRef = refVar env (Var v (map (fmap (const Nothing)) indices))
                case mObjRef of
                  Just objRef -> evalRef objRef
                  Nothing     -> evalExprShallow env expr
              _ -> evalExprShallow env expr
  case whnf of
    Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do
      js2 <- mapM evalIndexToScalar indices
      return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (js' ++ js2), 1)]))
    Value (Func v@(Just (Var _fnName is)) env args body) -> do
      js <- mapM evalIndex indices
      liftIO $ putStrLn $ "[DEBUG pmIndices] is: " ++ show is ++ ", js: " ++ show js
      frame <- pmIndices is js
      liftIO $ putStrLn $ "can reach here"
      let env' = extendEnv env frame
      return $ Value (Func v env' args body)
    Value (TensorData t@Tensor{}) -> do
      js <- mapM evalIndex indices
      Value <$> refTensorWithOverride override js t
    ITensor t@Tensor{} -> do
      js <- mapM evalIndex indices
      refTensorWithOverride override js t
    _ -> do
      js <- mapM evalIndex indices
      refHash whnf (map extractIndex js)
 where
  evalIndex :: Index IExpr -> EvalM (Index EgisonValue)
  evalIndex index = traverse (evalExprDeep env) index

  evalIndexToScalar :: Index IExpr -> EvalM (Index ScalarData)
  evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index

evalExprShallow env (ISubrefsExpr override expr jsExpr) = do
  js <- map Sub <$> (evalExprDeep env jsExpr >>= collectionToList)
  tensor <- case expr of
              IVarExpr xs -> do
                let mObjRef = refVar env (Var xs (map (\_ -> Sub Nothing) js))
                case mObjRef of
                  Just objRef -> evalRef objRef
                  Nothing     -> evalExprShallow env expr
              _ -> evalExprShallow env expr
  case tensor of
    Value (ScalarData _)          -> return tensor
    Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t
    ITensor t@Tensor{}            -> refTensorWithOverride override js t
    _ -> do
      val <- evalWHNF tensor
      case val of
        ScalarData _          -> return $ Value val
        TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t
        _                     -> throwErrorWithTrace (NotImplemented ("subrefs for " ++ show val))

evalExprShallow env (ISuprefsExpr override expr jsExpr) = do
  js <- map Sup <$> (evalExprDeep env jsExpr >>= collectionToList)
  tensor <- case expr of
              IVarExpr xs -> do
                let mObjRef = refVar env (Var xs (map (\_ -> Sup Nothing) js))
                case mObjRef of
                  Just objRef -> evalRef objRef
                  Nothing     -> evalExprShallow env expr
              _ -> evalExprShallow env expr
  case tensor of
    Value (ScalarData _)          -> return tensor
    Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t
    ITensor t@Tensor{}            -> refTensorWithOverride override js t
    _ -> do
      val <- evalWHNF tensor
      case val of
        ScalarData _          -> return $ Value val
        TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t
        _                     -> throwErrorWithTrace (NotImplemented ("suprefs for " ++ show val))

evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do
  val <- evalExprDeep env expr
  js <- map User <$> (evalExprDeep env jsExpr >>= collectionToList >>= mapM extractScalar)
  case val of
    ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) ->
      return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)]))
    ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]) ->
      case sym of
        SingleTerm 1 [(Symbol id name is, 1)] -> do
          let sym' = SingleTerm 1 [(Symbol id name (is ++ js), 1)]
          return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' args, 1)]))
        _ -> throwErrorWithTrace (NotImplemented "user-refs")
    _ -> throwErrorWithTrace (NotImplemented "user-refs")

evalExprShallow env (ILambdaExpr vwi names expr) = do
  return . Value $ Func vwi env names expr

evalExprShallow env (IMemoizedLambdaExpr names body) = do
  hashRef <- liftIO $ newIORef HL.empty
  return . Value $ MemoizedFunc hashRef env names body

evalExprShallow env (ICambdaExpr name expr) = return . Value $ CFunc env name expr

evalExprShallow (Env _ Nothing _) (IFunctionExpr _) = throwError $ Default "function symbol is not bound to a variable"

evalExprShallow env@(Env _ (Just (name, is)) _) (IFunctionExpr args) = do
  args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractScalar
  is' <- mapM unwrapMaybeFromIndex is
  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) args', 1)])
 where
  unwrapMaybeFromIndex :: Index (Maybe ScalarData) -> EvalM (Index ScalarData) -- Maybe we can refactor this function
--  unwrapMaybeFromIndex = return . (fmap fromJust)
  unwrapMaybeFromIndex (Sub Nothing) = throwError $ Default "function symbol can be used only with generateTensor"
  unwrapMaybeFromIndex (Sup Nothing) = throwError $ Default "function symbol can be used only with generateTensor"
  unwrapMaybeFromIndex (Sub (Just i)) = return (Sub i)
  unwrapMaybeFromIndex (Sup (Just i)) = return (Sup i)

evalExprShallow env (IIfExpr test expr expr') = do
  test <- evalExprDeep env test >>= fromEgison
  evalExprShallow env $ if test then expr else expr'

evalExprShallow env (ILetExpr bindings expr) = do
  binding <- concat <$> mapM extractBindings bindings
  evalExprShallow (extendEnv env binding) expr
 where
  extractBindings :: IBindingExpr -> EvalM [Binding]
  extractBindings (PDPatVar var, expr) =
    newThunkRef (memorizeVarInEnv env var) expr >>= makeBindings [var] . (:[])
  extractBindings (pdp, expr) = do
    thunk <- newThunkRef env expr
    bindPrimitiveDataPattern pdp thunk

evalExprShallow env (ILetRecExpr bindings expr) = do
  env' <- recursiveMatchBind env bindings
  evalExprShallow env' expr

evalExprShallow env (ITransposeExpr vars expr) = do
  syms <- evalExprDeep env vars >>= collectionToList
  whnf <- evalExprShallow env expr
  case whnf of
    ITensor t            -> ITensor <$> tTranspose' syms t
    Value (TensorData t) -> Value . TensorData <$> tTranspose' syms t
    _                    -> return whnf

evalExprShallow env (IFlipIndicesExpr expr) = do
  whnf <- evalExprShallow env expr
  case whnf of
    ITensor t            -> ITensor <$> tFlipIndices t
    Value (TensorData t) -> Value . TensorData <$> tFlipIndices t
    _                    -> return whnf

evalExprShallow env (IWithSymbolsExpr vars expr) = do
  symId <- fresh
  syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars
  whnf <- evalExprShallow (extendEnv env (makeBindings' vars syms)) expr
  case whnf of
    Value (TensorData t@Tensor{}) -> Value . TensorData <$> removeTmpScripts symId t
    ITensor t@Tensor{}            -> ITensor <$> removeTmpScripts symId t
    _                             -> return whnf
 where
  isTmpSymbol :: String -> Index EgisonValue -> Bool
  isTmpSymbol symId index = symId == getSymId (extractIndex index)

  removeTmpScripts :: String -> Tensor a -> EvalM (Tensor a)
  removeTmpScripts symId (Tensor s xs is) = do
    let (ds, js) = partition (isTmpSymbol symId) is
    Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)
    return (Tensor s ys js)
  removeTmpScripts _ t@Scalar{} = return t


evalExprShallow env (IDoExpr bindings expr) = return $ Value $ IOFunc $ do
  let body = foldr genLet (IApplyExpr expr [IVarExpr "#1"]) bindings
  applyObj env (Value $ Func Nothing env [stringToVar "#1"] body) [WHNF (Value World)]
 where
  genLet (names, expr) expr' =
    case names of
      -- If names is an empty tuple pattern () or wildcard, ignore the result
      PDTuplePat [] ->
        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDWildCard], IApplyExpr expr [IVarExpr "#1"])] expr'
      PDWildCard ->
        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDWildCard], IApplyExpr expr [IVarExpr "#1"])] expr'
      -- Otherwise, bind the result as before
      _ ->
        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDPatVar (stringToVar "#2")], IApplyExpr expr [IVarExpr "#1"])] $
        ILetExpr [(names, IVarExpr "#2")] expr'

evalExprShallow env (IMatchAllExpr pmmode target matcher clauses) = do
  target <- evalExprShallow env target
  matcher <- evalExprShallow env matcher >>= evalMatcherWHNF
  f matcher target >>= fromMList
 where
  fromMList :: MList EvalM WHNFData -> EvalM WHNFData
  fromMList MNil = return . Value $ Collection Sq.empty
  fromMList (MCons val m) = do
    head <- IElement <$> newEvaluatedObjectRef val
    tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)
    seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]
    return $ ICollection seqRef
  f matcher target = do
      let tryMatchClause (pattern, expr) results = do
            result <- patternMatch pmmode env pattern target matcher
            mmap (flip evalExprShallow expr . extendEnv env) result >>= (`mappend` results)
      mfoldr tryMatchClause (return MNil) (fromList clauses)

evalExprShallow env (IMatchExpr pmmode target matcher clauses) = do
  target <- evalExprShallow env target
  matcher <- evalExprShallow env matcher >>= evalMatcherWHNF
  f matcher target
 where
  f matcher target = do
      let tryMatchClause (pattern, expr) cont = do
            result <- patternMatch pmmode env pattern target matcher
            case result of
              MCons bindings _ -> evalExprShallow (extendEnv env bindings) expr
              MNil             -> cont
      callstack <- getFuncNameStack
      foldr tryMatchClause (throwError $ MatchFailure callstack) clauses

evalExprShallow env (ISeqExpr expr1 expr2) = do
  _ <- evalExprDeep env expr1
  evalExprShallow env expr2

evalExprShallow env (IApplyExpr func args) = do
  func <- appendDF 0 <$> evalExprShallow env func
  case func of
    Value (InductiveData name []) ->
      IInductiveData name <$> mapM (newThunkRef env) args
    Value (TensorData t@Tensor{}) -> do
      let args' = map (newThunk env) args
      tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor >>= removeDF
    ITensor t@Tensor{} -> do
      let args' = map (newThunk env) args
      tMap (\f -> do
        f <- evalRef f
        newApplyObjThunkRef env f args') t >>= fromTensor >>= removeDF
    Value (MemoizedFunc hashRef env' names body) -> do
      args <- mapM (evalExprDeep env) args
      evalMemoizedFunc hashRef env' names body args >>= removeDF
    _ -> do
      let args' = map (newThunk env) args
      applyObj env func args' >>= removeDF

evalExprShallow env (IWedgeApplyExpr func args) = do
  func <- appendDF 0 <$> evalExprShallow env func
  args <- mapM (evalExprShallow env) args
  let args' = map WHNF (zipWith appendDF [1..] args)
  case func of
    Value (TensorData t@Tensor{}) ->
      tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor >>= removeDF
    ITensor t@Tensor{} ->
      tMap (\f -> do
        f <- evalRef f
        newApplyObjThunkRef env f args') t >>= fromTensor >>= removeDF
    Value (MemoizedFunc hashRef env names body) -> do
      args <- mapM evalWHNF args
      evalMemoizedFunc hashRef env names body args >>= removeDF
    _ -> applyObj env func args' >>= removeDF

evalExprShallow env (IMatcherExpr info) = return $ Value $ UserMatcher env info

evalExprShallow env (IGenerateTensorExpr fnExpr shapeExpr) = do
  shape <- evalExprDeep env shapeExpr >>= collectionToList
  ns    <- mapM fromEgison shape :: EvalM Shape
  xs    <- mapM (evalWithIndex env . map (\n -> SingleTerm n [])) (enumTensorIndices ns)
  return $ newITensor ns xs
 where
  evalWithIndex :: Env -> [ScalarData] {- index -} -> EvalM ObjectRef
  evalWithIndex env@(Env frame maybe_vwi pfEnv) ms = do
    let env' = maybe env (\(name, indices) -> Env frame (Just (name, zipWith changeIndex indices ms)) pfEnv) maybe_vwi
    fn <- evalExprShallow env' fnExpr
    newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map ScalarData ms))))]
  changeIndex :: Index (Maybe a) -> a -> Index (Maybe a) -- Maybe we can refactor this function
  changeIndex (Sup Nothing) m = Sup (Just m)
  changeIndex (Sub Nothing) m = Sub (Just m)

evalExprShallow env (ITensorContractExpr tExpr) = do
  whnf <- evalExprShallow env tExpr
  case whnf of
    ITensor t@Tensor{} -> do
      ts <- tContract t >>= mapM fromTensor
      makeICollection ts
    Value (TensorData t@Tensor{}) -> do
      ts <- tContract t >>= mapM fromTensor
      return $ Value $ Collection $ Sq.fromList ts
    _ -> makeICollection [whnf]

evalExprShallow env (ITensorMapExpr fnExpr tExpr) = do
  fn <- evalExprShallow env fnExpr
  whnf <- evalExprShallow env tExpr
  case whnf of
    ITensor t ->
      tMap (\x -> newApplyThunkRef env fn [x]) t >>= fromTensor
    Value (TensorData t) ->
      tMap (\x -> newApplyObjThunkRef env fn [WHNF (Value x)]) t >>= fromTensor
    _ -> applyObj env fn [WHNF whnf]

evalExprShallow env (ITensorMap2Expr fnExpr t1Expr t2Expr) = do
  fn <- evalExprShallow env fnExpr
  whnf1 <- evalExprShallow env t1Expr
  whnf2 <- evalExprShallow env t2Expr
  case (whnf1, whnf2) of
    -- both of arguments are tensors
    (ITensor t1, ITensor t2) ->
      tMap2 (\x y -> newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor
    (ITensor t1, Value (TensorData t2)) -> do
      tMap2 (\x y -> do
        y <- newEvaluatedObjectRef (Value y)
        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor
    (Value (TensorData t1), ITensor t2) -> do
      tMap2 (\x y -> do
        x <- newEvaluatedObjectRef (Value x)
        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor
    (Value (TensorData t1), Value (TensorData t2)) ->
      tMap2 (\x y -> newApplyObjThunkRef env fn [WHNF (Value x), WHNF (Value y)]) t1 t2 >>= fromTensor
    -- an argument is scalar
    (ITensor t1, _) -> do
      y <- newEvaluatedObjectRef whnf2
      tMap (\x -> newApplyThunkRef env fn [x, y]) t1 >>= fromTensor
    (_, ITensor t2) -> do
      x <- newEvaluatedObjectRef whnf1
      tMap (\y -> newApplyThunkRef env fn [x, y]) t2 >>= fromTensor
    (Value (TensorData t1), _) -> do
      y <- newEvaluatedObjectRef whnf2
      tMap (\x -> do
        x <- newEvaluatedObjectRef (Value x)
        newApplyThunkRef env fn [x, y]) t1 >>= fromTensor
    (_, Value (TensorData t2)) -> do
      x <- newEvaluatedObjectRef whnf1
      tMap (\y -> do
        y <- newEvaluatedObjectRef (Value y)
        newApplyThunkRef env fn [x, y]) t2 >>= fromTensor
    _ -> applyObj env fn [WHNF whnf1, WHNF whnf2]

evalExprShallow env (ITensorMap2WedgeExpr fnExpr t1Expr t2Expr) = do
  fn <- evalExprShallow env fnExpr
  whnf1 <- evalExprShallow env t1Expr
  whnf2 <- evalExprShallow env t2Expr
  -- Apply different indices to the whole tensors (like WedgeApply)
  let whnf1' = appendDF 1 whnf1
      whnf2' = appendDF 2 whnf2
  case (whnf1', whnf2') of
    -- both of arguments are tensors
    (ITensor t1, ITensor t2) ->
      tMap2 (\x y -> newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF
    (ITensor t1, Value (TensorData t2)) -> do
      tMap2 (\x y -> do
        y <- newEvaluatedObjectRef (Value y)
        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF
    (Value (TensorData t1), ITensor t2) -> do
      tMap2 (\x y -> do
        x <- newEvaluatedObjectRef (Value x)
        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF
    (Value (TensorData t1), Value (TensorData t2)) ->
      tMap2 (\x y -> newApplyObjThunkRef env fn [WHNF (Value x), WHNF (Value y)]) t1 t2 >>= fromTensor >>= removeDF
    -- an argument is scalar - this shouldn't happen for tensorMap2Wedge
    _ -> throwErrorWithTrace (TypeMismatch "tensor" whnf1)

evalExprShallow env (IPatternFuncExpr paramNames body) =
  -- Create a PatternFunc value, capturing the current environment
  return $ Value (PatternFunc env paramNames body)

evalExprShallow _ expr = throwErrorWithTrace (NotImplemented ("evalExprShallow for " ++ show expr))

evalExprDeep :: Env -> IExpr -> EvalM EgisonValue
evalExprDeep env expr = evalExprShallow env expr >>= evalWHNF

evalRefDeep :: ObjectRef -> EvalM EgisonValue
evalRefDeep ref = do
  obj <- liftIO $ readIORef ref
  case obj of
    WHNF (Value val) -> return val
    WHNF val -> do
      val <- evalWHNF val
      writeObjectRef ref $ Value val
      return val
    Thunk thunk -> do
      val <- thunk >>= evalWHNF
      writeObjectRef ref $ Value val
      return val

evalMemoizedFunc
  :: IORef (HL.HashMap [Integer] WHNFData) -> Env -> [String] -> IExpr
  -> [EgisonValue] -> EvalM WHNFData
evalMemoizedFunc hashRef env names body args = do
  indices <- mapM fromEgison args
  hash <- liftIO $ readIORef hashRef
  case HL.lookup indices hash of
    Just whnf -> return whnf
    Nothing -> do
      whnf <- applyObj env (Value (Func Nothing env (map stringToVar names) body)) (map (WHNF . Value) args)
      liftIO $ modifyIORef hashRef (HL.insert indices whnf)
      return whnf

evalWHNF :: WHNFData -> EvalM EgisonValue
evalWHNF (Value val) = return val
evalWHNF (IInductiveData name refs) =
  InductiveData name <$> mapM evalRefDeep refs
evalWHNF (IIntHash refs)  = IntHash  <$> mapM evalRefDeep refs
evalWHNF (ICharHash refs) = CharHash <$> mapM evalRefDeep refs
evalWHNF (IStrHash refs)  = StrHash  <$> mapM evalRefDeep refs
evalWHNF (ITuple [ref]) = evalRefDeep ref
evalWHNF (ITuple refs) = Tuple <$> mapM evalRefDeep refs
evalWHNF (ITensor (Tensor ns whnfs js)) = do
  vals <- V.mapM evalRefDeep whnfs
  return $ TensorData $ Tensor ns vals js
evalWHNF coll = Collection <$> (collectionToRefs coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList)

addscript :: (Index EgisonValue, Tensor a) -> Tensor a
addscript (subj, Tensor s t i) = Tensor s t (i ++ [subj])

newApplyThunk :: Env -> WHNFData -> [ObjectRef] -> Object
newApplyThunk env fn refs = Thunk $ applyRef env fn refs

newApplyThunkRef :: Env -> WHNFData -> [ObjectRef] -> EvalM ObjectRef
newApplyThunkRef env fn refs = liftIO . newIORef $ newApplyThunk env fn refs

newApplyObjThunk :: Env -> WHNFData -> [Object] -> Object
newApplyObjThunk env fn objs = Thunk $ applyObj env fn objs

newApplyObjThunkRef :: Env -> WHNFData -> [Object] -> EvalM ObjectRef
newApplyObjThunkRef env fn objs = liftIO . newIORef $ newApplyObjThunk env fn objs

applyRef :: Env -> WHNFData -> [ObjectRef] -> EvalM WHNFData
applyRef env (Value (TensorData (Tensor s1 t1 i1))) refs = do
  tds <- mapM evalRef refs
  if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds
    then do
      symId <- fresh
      let argnum = length tds
          subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum]
          supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum]
      dot <- evalExprShallow env (IVarExpr ".")
      tds' <- mapM toTensor tds
      let args' = Value (TensorData (Tensor s1 t1 (i1 ++ supjs))) : map (ITensor . addscript) (zip subjs tds')
      applyObj env dot (map WHNF args')
    else throwError $ Default "applyObj"
applyRef env (ITensor (Tensor s1 t1 i1)) refs = do
  tds <- mapM evalRef refs
  if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds
    then do
      symId <- fresh
      let argnum = length tds
          subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum]
          supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum]
      dot <- evalExprShallow env (IVarExpr ".")
      tds' <- mapM toTensor tds
      let args' = ITensor (Tensor s1 t1 (i1 ++ supjs)) : map (ITensor . addscript) (zip subjs tds')
      applyObj env dot (map WHNF args')
    else throwError $ Default "applyfunc"
applyRef env' (Value (Func mFuncName env names body)) refs =
  mLabelFuncName mFuncName $
    if | length names == length refs -> do
         frame <- makeBindings names refs
         evalExprShallow (extendEnv env frame) body
       | length names > length refs -> do -- Currying
         let (bound, rest) = splitAt (length refs) names
         frame <- makeBindings bound refs
         return . Value $ Func mFuncName (extendEnv env frame) rest body
       | otherwise -> do
         let (used, rest) = splitAt (length names) refs
         frame <- makeBindings names used
         func <- evalExprShallow (extendEnv env frame) body
         applyRef env' func rest
applyRef _ (Value (CFunc env name body)) refs = do
  seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)
  col <- liftIO . newIORef $ WHNF $ ICollection seqRef
  evalExprShallow (extendEnv env $ makeBindings' [name] [col]) body
applyRef _ (Value (PrimitiveFunc func)) refs = do
  vals <- mapM (\ref -> evalRef ref >>= evalWHNF) refs
  Value <$> func vals
applyRef _ (Value (LazyPrimitiveFunc func)) refs = do
  whnfs <- mapM evalRef refs
  func whnfs
applyRef _ (Value (IOFunc m)) refs = do
  args <- mapM evalRef refs
  case args of
    [Value World] -> m
    arg : _       -> throwErrorWithTrace (TypeMismatch "world" arg)
applyRef _ (Value (ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]))) refs = do
  newArgs <- mapM (\ref -> evalRef ref >>= evalWHNF) refs
  newScalars <- mapM (\arg -> case arg of
    ScalarData s -> return s
    _ -> throwErrorWithTrace (TypeMismatch "scalar" (Value arg))) newArgs
  when (length newScalars /= length args) $
    throwError (Default ("function applied to wrong number of arguments: expected "
      ++ show (length args) ++ ", got " ++ show (length newScalars)))
  return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym newScalars, 1)]))
applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol _ symName _, 1)]))) refs = do
  args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs
  mExprs <- mapM (\arg -> case arg of
                            ScalarData _ -> extractScalar arg
                            _            -> throwErrorWithTrace (EgisonBug $ "to use undefined function '" ++ symName ++ "', you have to use ScalarData args")) args
  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))
-- QuoteFunction pattern: ('fact 3) should create Apply1 fact 3
-- The quoted function object is stored in QuoteFunction
applyRef env (Value (ScalarData fn@(SingleTerm 1 [(QuoteFunction funcWHNF, 1)]))) refs = do
  args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs
  mExprs <- mapM (\arg -> case arg of
                            ScalarData scalar -> return scalar
                            _                 -> throwErrorWithTrace (EgisonBug $ "to use quoted function, you have to use ScalarData args")) args
  -- Create Apply1/Apply2/etc with the function object
  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))
-- Type class method dispatch: look up implementation based on first argument's type
-- Uses Type from Types.hs for dispatch (not String-based typeName)
applyRef env (Value (ClassMethodRef clsName methName)) refs = do
  case refs of
    [] -> return $ Value (ClassMethodRef clsName methName)  -- Partial application
    (firstRef:_) -> do
      -- Evaluate to WHNF and get Type directly (without full evaluation)
      firstArgWhnf <- evalRef firstRef
      let argType = whnfToType firstArgWhnf
      -- Look up implementation from instance environment using Type
      mImpl <- lookupInstance clsName methName argType
      case mImpl of
        Just implName -> do
          -- Look up the implementation function by name and apply
          case refVar env (stringToVar implName) of
            Just implRef -> do
              impl <- evalRef implRef
              applyRef env impl refs  -- Apply all arguments to the implementation
            Nothing -> throwError (Default 
              ("Instance method not found: " ++ implName))
        Nothing -> throwError (Default 
          ("No instance of " ++ clsName ++ " for type " ++ show argType))
applyRef _ whnf _ = throwErrorWithTrace (TypeMismatch "function" whnf)

applyObj :: Env -> WHNFData -> [Object] -> EvalM WHNFData
applyObj env fn args = do
  refs <- liftIO $ mapM newIORef args
  applyRef env fn refs

refHash :: WHNFData -> [EgisonValue] -> EvalM WHNFData
refHash val [] = return val
refHash val (index:indices) =
  case val of
    Value (IntHash hash)  -> refHash' hash
    Value (CharHash hash) -> refHash' hash
    Value (StrHash hash)  -> refHash' hash
    IIntHash hash         -> irefHash hash
    ICharHash hash        -> irefHash hash
    IStrHash hash         -> irefHash hash
    _                     -> throwErrorWithTrace (TypeMismatch "hash" val)
 where
  refHash' hash = do
    key <- fromEgison index
    case HL.lookup key hash of
      Just val -> refHash (Value val) indices
      Nothing  -> return $ Value Undefined

  irefHash hash = do
    key <- fromEgison index
    case HL.lookup key hash of
      Just ref -> evalRef ref >>= flip refHash indices
      Nothing  -> return $ Value Undefined

subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)]
subst k nv ((k', v'):xs) | k == k'   = (k', nv):subst k nv xs
                         | otherwise = (k', v'):subst k nv xs
subst _ _ [] = []

newThunk :: Env -> IExpr -> Object
newThunk env expr = Thunk $ evalExprShallow env expr

newThunkRef :: Env -> IExpr -> EvalM ObjectRef
newThunkRef env expr = liftIO . newIORef $ newThunk env expr

recursiveBind :: Env -> [(Var, IExpr)] -> EvalM Env
recursiveBind env bindings = do
  -- Create dummy bindings first. Since this is a reference,
  -- it can be overwritten later.
  binds <- mapM (\(var, _) -> (var,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) bindings
  let env' = extendEnv env binds
  forM_ bindings $ \(var, expr) -> do
    let env'' = memorizeVarInEnv env' var
    let ref = fromJust (refVar env' var)
    -- Set function name for top-level lambda definitions
    let expr' = case expr of
                  ILambdaExpr Nothing args body -> ILambdaExpr (Just var) args body
                  _ -> expr
    liftIO $ writeIORef ref (newThunk env'' expr')
  return env'

-- | Bind pattern function definitions into the pattern function environment.
-- Analogous to 'recursiveBind' but uses the separate 'PatFuncEnv' so that
-- pattern functions never pollute the regular value environment.
-- Supports mutual recursion among pattern functions.
recursiveBindPatFuncs :: Env -> [(String, IExpr)] -> EvalM Env
recursiveBindPatFuncs env [] = return env
recursiveBindPatFuncs env bindings = do
  -- Create dummy refs so that mutually-recursive pattern functions can reference
  -- each other via the env that will be closed over by each PatternFunc value.
  refs <- mapM (\_ -> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) bindings
  let namedRefs = zip (map fst bindings) refs
  let env' = extendPatFuncEnv env namedRefs
  -- Fill in each ref with the real thunk, closing over env' so that pattern
  -- functions can call each other.
  forM_ (zip (map snd bindings) refs) $ \(expr, ref) ->
    liftIO $ writeIORef ref (newThunk env' expr)
  return env'

-- | Bind regular value definitions and pattern function definitions together in
-- one step, so that all thunks are closed over a single environment that
-- contains both regular values (in the normal env layers) and pattern functions
-- (in the patFuncEnv).  This is necessary for mutual visibility: ordinary
-- definitions can invoke pattern functions (e.g. in matchAll expressions), and
-- pattern functions can invoke other pattern functions.
recursiveBindAll :: Env -> [(Var, IExpr)] -> [(String, IExpr)] -> EvalM Env
recursiveBindAll env valBindings patFuncBindings = do
  -- 1. Create dummy refs for regular value bindings.
  valBinds <- mapM (\(var, _) -> (var,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) valBindings
  -- 2. Create dummy refs for pattern function bindings.
  pfRefs  <- mapM (\_ -> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) patFuncBindings
  let pfNamedRefs = zip (map fst patFuncBindings) pfRefs
  -- 3. Build a combined env: regular layers + patFuncEnv, both containing dummies.
  let envWithVal  = extendEnv env valBinds
  let envFinal    = extendPatFuncEnv envWithVal pfNamedRefs
  -- 4. Fill in regular value thunks, closing over envFinal.
  forM_ valBindings $ \(var, expr) -> do
    let envForVar = memorizeVarInEnv envFinal var
    let ref = fromJust (refVar envFinal var)
    let expr' = case expr of
                  ILambdaExpr Nothing args body -> ILambdaExpr (Just var) args body
                  _ -> expr
    liftIO $ writeIORef ref (newThunk envForVar expr')
  -- 5. Fill in pattern function thunks, closing over envFinal.
  forM_ (zip (map snd patFuncBindings) pfRefs) $ \(expr, ref) ->
    liftIO $ writeIORef ref (newThunk envFinal expr)
  return envFinal

recursiveMatchBind :: Env -> [IBindingExpr] -> EvalM Env
recursiveMatchBind env bindings = do
  -- List of variables defined in |bindings|
  let names = concatMap (\(pd, _) -> toList pd) bindings
  -- Create dummy bindings for |names| first. Since this is a reference,
  -- it can be overwritten later.
  binds <- mapM (\name -> (name,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) names
  let env' = extendEnv env binds
  forM_ bindings $ \(pd, expr) -> do
    -- Modify |env'| for some cases
    let env'' = case pd of
                  PDPatVar var -> memorizeVarInEnv env' var
                  _            -> env'
    thunk <- newThunkRef env'' expr
    binds <- bindPrimitiveDataPattern pd thunk
    forM_ binds $ \(var, objref) -> do
      -- Get an Object |obj| being bound to |var|.
      obj <- liftIO $ readIORef objref
      let ref = fromJust (refVar env' var)
      liftIO $ writeIORef ref obj
  return env'

memorizeVarInEnv :: Env -> Var -> Env
memorizeVarInEnv (Env frame _ pfEnv) (Var var is) =
  Env frame (Just (var, map (fmap (\_ -> Nothing)) is)) pfEnv

--
-- Pattern Match
--

patternMatch :: PMMode -> Env -> IPattern -> WHNFData -> Matcher -> EvalM (MList EvalM Match)
patternMatch pmmode env pattern target matcher =
  case pmmode of
    DFSMode -> processMStatesAllDFS (msingleton initMState)
    BFSMode -> processMStatesAll [msingleton initMState]
  where
    initMState = MState { mStateEnv      = env
                        , loopPatCtx     = []
                        , seqPatCtx      = []
                        , mStateBindings = []
                        , mTrees         = [MAtom pattern target matcher]
                        }

processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match)
processMStatesAllDFS MNil                                   = return MNil
processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms
processMStatesAllDFS (MCons mstate ms)                      = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS

processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState)
processMStatesAllDFSForall MNil                                                           = return MNil
processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms
processMStatesAllDFSForall (MCons mstate ms)                                              = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall

processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match)
processMStatesAll [] = return MNil
processMStatesAll streams = do
  (matches, streams') <- mapM processMStates streams >>= extractMatches . concat
  mappend (fromList matches) $ processMStatesAll streams'

processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState]
processMStates MNil                 = return []
processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream

extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState])
extractMatches = extractMatches' ([], [])
 where
  extractMatches' :: ([Match], [MList EvalM MatchingState]) -> [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState])
  extractMatches' (xs, ys) [] = return (xs, ys)
  extractMatches' (xs, ys) (MCons (gatherBindings -> Just bindings) states : rest) = do
    states' <- states
    extractMatches' (xs ++ [bindings], ys ++ [states']) rest
  extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest

gatherBindings :: MatchingState -> Maybe [Binding]
gatherBindings MState{ seqPatCtx = [], mStateBindings = b, mTrees = [] } = return b
gatherBindings _                                                         = Nothing

processMState :: MatchingState -> EvalM (MList EvalM MatchingState)
processMState state | nullMState state = processMState' state
processMState state =
  case splitMState state of
    (1, state1, state2) -> do
      result <- processMStatesAllDFS (msingleton state1)
      case result of
        MNil -> return $ msingleton state2
        _    -> return MNil
    (0, MState e l s b [MAtom (IForallPat p1 p2) m t], MState{ mTrees = trees }) -> do
      states <- processMStatesAllDFSForall (msingleton (MState e l (ForallPatContext [] []:s) b [MAtom p1 m t]))
      statess' <- mmap (\(MState e' l' (ForallPatContext ms ts:s') b' []) -> do
                            let mat' = makeTuple ms
                            tgt' <- makeITuple ts
                            processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states
      b <- mAny (\case
                   MNil -> return True
                   _    -> return False) statess'
      if b
        then return MNil
--        else return MNil
        else do nstatess <- mmap (mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees)) statess'
                mconcat nstatess
    _ -> processMState' state
 where
  splitMState :: MatchingState -> (Integer, MatchingState, MatchingState)
  splitMState mstate@MState{ mTrees = MAtom (INotPat pattern) target matcher : trees } =
    (1, mstate { seqPatCtx = [],  mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })
  splitMState mstate@MState{ mTrees = MAtom pattern target matcher : trees } =
    (0, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })
  splitMState mstate@MState{ mTrees = MNode penv state' : trees } =
    (f, mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees })
      where (f, state1, state2) = splitMState state'

processMState' :: MatchingState -> EvalM (MList EvalM MatchingState)
--processMState' MState{ seqPatCtx = [], mTrees = [] } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-state)")
processMState' mstate@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS)

-- Sequential patterns and forall pattern
processMState' mstate@MState{ seqPatCtx = SeqPatContext stack ISeqNilPat [] []:seqs, mTrees = [] } =
  return . msingleton $ mstate { seqPatCtx = seqs, mTrees = stack }
processMState' mstate@MState{ seqPatCtx = SeqPatContext stack seqPat mats tgts:seqs, mTrees = [] } = do
  let mat' = makeTuple mats
  tgt' <- makeITuple tgts
  return . msingleton $ mstate { seqPatCtx = seqs, mTrees = MAtom seqPat tgt' mat' : stack }
processMState' mstate@MState{ seqPatCtx = ForallPatContext _ _:_, mTrees = [] } =
  return . msingleton $ mstate

-- Matching Nodes
--processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-node)")
processMState' mstate@MState{ mTrees = MNode _ MState{ seqPatCtx = [], mTrees = [] }:trees } = return . msingleton $ mstate { mTrees = trees }

processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (IVarPat name) target matcher:trees' }:trees } =
  case lookup name penv of
    Just pattern ->
      case trees' of
        [] -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:trees }
        _  -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:MNode penv (ms2 { mTrees = trees' }):trees }
    Nothing -> throwErrorWithTrace (UnboundVariable name)

processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IIndexedPat (IVarPat name) indices) target matcher:trees')):trees)) =
  case lookup name penv of
    Just pattern -> do
      let env'' = extendEnvForNonLinearPatterns env' bindings loops'
      indices <- mapM (evalExprDeep env'' >=> fmap fromInteger . fromEgison) indices
      let pattern' = IIndexedPat pattern $ map (IConstantExpr . IntegerExpr) indices
      case trees' of
        [] -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:trees }
        _  -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:MNode penv (ms2 { mTrees = trees' }):trees }
    Nothing -> throwErrorWithTrace (UnboundVariable name)

processMState' mstate@MState{ mTrees = MNode penv state:trees } =
  processMState' state >>= mmap (\state' -> case state' of
--egi                                              MState { mTrees = [] } -> return $ mstate { mTrees = trees }
                                              _ -> return $ mstate { mTrees = MNode penv state':trees })

-- Matching Atoms
processMState' mstate@(MState env loops seqs bindings (MAtom pattern target matcher:trees)) =
  let env' = extendEnvForNonLinearPatterns env bindings loops in
  case pattern of
    IInductiveOrPApplyPat name args ->
      -- Check the pattern function environment first (separate from the value env).
      -- If found there it must be a PatternFunc; otherwise treat as an inductive
      -- pattern constructor.
      case refPatFunc env name of
        Just _  -> processMState' (mstate { mTrees = MAtom (IPApplyPat (IVarExpr name) args) target matcher:trees })
        Nothing -> processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees })

    INotPat _ -> throwErrorWithTrace (EgisonBug "should not reach here (not-pattern)")
    IVarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern

    ILetPat bindings' pattern' -> do
      b <- concat <$> mapM extractBindings bindings'
      return . msingleton $ mstate { mStateBindings = b ++ bindings, mTrees = MAtom pattern' target matcher:trees }
        where
          extractBindings (pdp, expr) = do
            thunk <- newThunkRef (extendEnv env bindings) expr
            bindPrimitiveDataPattern pdp thunk

    IPredPat predicate -> do
      func <- evalExprShallow env' predicate
      result <- applyObj env func [WHNF target] >>= evalWHNF >>= fromEgison
      if result then return . msingleton $ mstate { mTrees = trees }
                else return MNil

    IPApplyPat func args -> do
      -- For a plain variable, look up the pattern function environment first so
      -- that pattern functions and ordinary values live in separate namespaces.
      func' <- case func of
        IVarExpr name ->
          case refPatFunc env' name of
            Just ref -> evalRef ref
            Nothing  -> evalExprShallow env' func
        _ -> evalExprShallow env' func
      case func' of
        Value (PatternFunc env'' names expr) ->
          return . msingleton $ mstate { mTrees = MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees }
            where penv = zip names args
        _ -> throwErrorWithTrace (TypeMismatch "pattern constructor" func')

    IDApplyPat func args ->
      return . msingleton $ mstate { mTrees = MAtom (IInductivePat "apply" [func, toListPat args]) target matcher:trees }

    ILoopPat name (ILoopRange start ends endPat) pat pat' -> do
      startNum    <- evalExprDeep env' start >>= fromEgison :: (EvalM Integer)
      startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1)
      ends'       <- evalExprShallow env' ends
      case ends' of
        Value (ScalarData _) -> do -- the case when the end numbers are an integer
          endsRef  <- newEvaluatedObjectRef ends'
          inners   <- liftIO . newIORef $ Sq.fromList [IElement endsRef]
          endsRef' <- liftIO $ newIORef (WHNF (ICollection inners))
          return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops
                                       , mTrees = MAtom IContPat target matcher:trees }
        _ -> do -- the case when the end numbers are a collection
          endsRef <- newEvaluatedObjectRef ends'
          return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops
                                       , mTrees = MAtom IContPat target matcher:trees }
    IContPat ->
      case loops of
        [] -> throwError $ Default "cannot use cont pattern except in loop pattern"
        LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do
          startNumVal <- evalRefDeep startNumRef
          startNum <- fromEgison startNumVal :: (EvalM Integer)
          nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1)
          ends <- evalRef endsRef
          b <- isEmptyCollection ends
          if b
            then return MNil
            else do
              (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends)
              b2 <- evalRef cdrEndsRef >>= isEmptyCollection
              carEndsNum <- evalRefDeep carEndsRef >>= fromEgison
              return $ if
                | startNum >  carEndsNum -> MNil
                | startNum == carEndsNum && b2 ->
                  fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat (Value startNumVal) Something:MAtom pat' target matcher:trees }]
                | startNum == carEndsNum ->
                  fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat (Value startNumVal) Something:MAtom pat' target matcher:trees },
                            mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]
                | otherwise ->
                  fromList [mstate { loopPatCtx = LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]
    ISeqNilPat -> throwErrorWithTrace (EgisonBug "should not reach here (seq nil pattern)")
    ISeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher]
    ILaterPatVar ->
      case seqs of
        [] -> throwError $ Default "cannot use # out of seq patterns"
        SeqPatContext stack pat mats tgts:seqs ->
          return . msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees
        ForallPatContext mats tgts:seqs ->
          return . msingleton $ MState env loops (ForallPatContext (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees
    IAndPat pat1 pat2 ->
      let trees' = [MAtom pat1 target matcher, MAtom pat2 target matcher] ++ trees
       in return . msingleton $ mstate { mTrees = trees' }
    IOrPat pat1 pat2 ->
      return $ fromList [mstate { mTrees = MAtom pat1 target matcher : trees }, mstate { mTrees = MAtom pat2 target matcher : trees }]

    _ ->
      case matcher of
        UserMatcher{} -> do
          (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher
          case length patterns of
            1 ->
              mfor targetss $ \ref -> do
                targets <- evalRef ref >>= (\x -> return [x])
                let trees' = zipWith3 MAtom patterns targets matchers ++ trees
                return $ mstate { mTrees = trees' }
            _ ->
              mfor targetss $ \ref -> do
                targets <- evalRef ref >>= tupleToListWHNF
                let trees' = zipWith3 MAtom patterns targets matchers ++ trees
                return $ mstate { mTrees = trees' }

        Tuple matchers ->
          case pattern of
            IValuePat _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }
            IWildCard   -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }
            IPatVar _   -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }
            IIndexedPat _ _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }
            ITuplePat patterns -> do
              targets <- tupleToListWHNF target
              when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets))
              when (length patterns /= length matchers) $ throwErrorWithTrace (TupleLength (length patterns) (length matchers))
              let trees' = zipWith3 MAtom patterns targets matchers ++ trees
              return . msingleton $ mstate { mTrees = trees' }
            _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern

        Something ->
          case pattern of
            IValuePat valExpr -> do
              val <- evalExprDeep env' valExpr
              tgtVal <- evalWHNF target
              if val == tgtVal
                then return . msingleton $ mstate { mTrees = trees }
                else return MNil
            IWildCard -> return . msingleton $ mstate { mTrees = trees }
            IPatVar name -> do
              targetRef <- newEvaluatedObjectRef target
              return . msingleton $ mstate { mStateBindings = (stringToVar name, targetRef):bindings, mTrees = trees }
            IIndexedPat (IPatVar name') indices -> do
              let name = stringToVar name'
              indices <- mapM (evalExprDeep env' >=> fmap fromInteger . fromEgison) indices
              case lookup name bindings of
                Just ref -> do
                  obj <- evalRef ref >>= updateHash indices target >>= newEvaluatedObjectRef
                  return . msingleton $ mstate { mStateBindings = subst name obj bindings, mTrees = trees }
                Nothing  -> do
                  obj <- updateHash indices target (IIntHash HL.empty) >>= newEvaluatedObjectRef
                  return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees }
            IIndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern)
            ITuplePat patterns -> do
              targets <- tupleToListWHNF target
              when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets))
              let trees' = zipWith3 MAtom patterns targets (map (const Something) patterns) ++ trees
              return . msingleton $ mstate { mTrees = trees' }
            _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ show pattern
        _ ->  throwErrorWithTrace (EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern))

inductiveMatch :: Env -> IPattern -> WHNFData -> Matcher ->
                  EvalM ([IPattern], MList EvalM ObjectRef, [Matcher])
inductiveMatch env pattern target (UserMatcher matcherEnv clauses) =
  foldr tryPPMatchClause failPPPatternMatch clauses
 where
  tryPPMatchClause (pat, matchers, clauses) cont = do
    result <- runMaybeT $ primitivePatPatternMatch env pat pattern
    case result of
      Just ([pattern], bindings) -> do
        targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses
        matcher <- evalExprShallow matcherEnv matchers >>= evalMatcherWHNF
        return ([pattern], targetss, [matcher])
      Just (patterns, bindings) -> do
        targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses
        matchers <- tupleToList <$> (evalExprShallow matcherEnv matchers >>= evalMatcherWHNF)
        return (patterns, targetss, matchers)
      _ -> cont
  tryPDMatchClause bindings (pat, expr) cont = do
    ref <- newEvaluatedObjectRef target
    result <- runMaybeT $ primitiveDataPatternMatch pat ref
    case result of
      Just bindings' -> do
        let env = extendEnv matcherEnv $ bindings ++ bindings'
        evalExprShallow env expr >>= collectionToRefs
      _ -> cont
  failPPPatternMatch = throwError (Default "failed primitive pattern pattern match")
  failPDPatternMatch = throwErrorWithTrace PrimitiveMatchFailure

primitivePatPatternMatch :: Env -> PrimitivePatPattern -> IPattern ->
                            MatchM ([IPattern], [Binding])
primitivePatPatternMatch _ PPWildCard IWildCard = return ([], [])
primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], [])
primitivePatPatternMatch env (PPValuePat name) (IValuePat expr) = do
  ref <- lift $ newThunkRef env expr
  return ([], [(stringToVar name, ref)])
primitivePatPatternMatch env (PPInductivePat name patterns) (IInductivePat name' exprs)
  | name == name' && length patterns == length exprs =
    (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs
  | otherwise = matchFail
primitivePatPatternMatch env (PPTuplePat patterns) (ITuplePat exprs)
  | length patterns == length exprs =
    (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs
  | otherwise = matchFail
primitivePatPatternMatch _ _ _ = matchFail

bindPrimitiveDataPattern :: IPrimitiveDataPattern -> ObjectRef -> EvalM [Binding]
bindPrimitiveDataPattern pdp ref = do
  r <- runMaybeT $ primitiveDataPatternMatch pdp ref
  case r of
    Nothing      -> throwErrorWithTrace PrimitiveMatchFailure
    Just binding -> return binding

-- Helper functions to convert internal math types to ScalarData (MathExpr)
polyExprToScalarData :: PolyExpr -> ScalarData
polyExprToScalarData polyExpr = Div polyExpr (Plus [Term 1 []])

termExprToScalarData :: TermExpr -> ScalarData
termExprToScalarData termExpr = Div (Plus [termExpr]) (Plus [Term 1 []])

symbolExprToScalarData :: SymbolExpr -> ScalarData
symbolExprToScalarData symbolExpr = Div (Plus [Term 1 [(symbolExpr, 1)]]) (Plus [Term 1 []])

-- Check if pattern is a pattern variable
isPatternVar :: IPrimitiveDataPattern -> Bool
isPatternVar (PDPatVar _) = True
isPatternVar _            = False

-- Helper: Extract function object from ScalarData if it contains QuoteFunction
extractFunctionObject :: ScalarData -> WHNFData
extractFunctionObject (SingleTerm 1 [(QuoteFunction funcWHNF, 1)]) = funcWHNF
extractFunctionObject scalarData = Value (ScalarData scalarData)

primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding]
primitiveDataPatternMatch PDWildCard _        = return []
primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)]
primitiveDataPatternMatch (PDInductivePat name patterns) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    IInductiveData name' refs | name == name' ->
      concat <$> zipWithM primitiveDataPatternMatch patterns refs
    Value (InductiveData name' vals) | name == name' -> do
      whnfs <- lift $ mapM (newEvaluatedObjectRef . Value) vals
      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs
    _ -> matchFail
primitiveDataPatternMatch (PDTuplePat patterns) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    ITuple refs -> do
      concat <$> zipWithM primitiveDataPatternMatch patterns refs
    Value (Tuple vals) -> do
      whnfs <- lift $ mapM (newEvaluatedObjectRef . Value) vals
      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs
    _ -> matchFail
primitiveDataPatternMatch PDEmptyPat ref = do
  whnf <- lift $ evalRef ref
  isEmpty <- lift $ isEmptyCollection whnf
  if isEmpty then return [] else matchFail
primitiveDataPatternMatch (PDConsPat pattern pattern') ref = do
  whnf <- lift $ evalRef ref
  (head, tail) <- unconsCollection whnf
  (++) <$> primitiveDataPatternMatch pattern head
       <*> primitiveDataPatternMatch pattern' tail
primitiveDataPatternMatch (PDSnocPat pattern pattern') ref = do
  whnf <- lift $ evalRef ref
  (init, last) <- unsnocCollection whnf
  (++) <$> primitiveDataPatternMatch pattern init
       <*> primitiveDataPatternMatch pattern' last
primitiveDataPatternMatch (PDConstantPat expr) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value val | val == evalConstant expr -> return []
    _                                    -> matchFail
-- ScalarData (MathExpr) primitive patterns
primitiveDataPatternMatch (PDDivPat patNum patDen) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (ScalarData (Div num den)) -> do
      -- Pattern variable の場合は PolyExpr -> ScalarData に変換
      let numVal = if isPatternVar patNum 
                   then Value (ScalarData (polyExprToScalarData num))
                   else Value (PolyExprData num)
      let denVal = if isPatternVar patDen
                   then Value (ScalarData (polyExprToScalarData den))
                   else Value (PolyExprData den)
      numRef <- lift $ newEvaluatedObjectRef numVal
      denRef <- lift $ newEvaluatedObjectRef denVal
      (++) <$> primitiveDataPatternMatch patNum numRef
           <*> primitiveDataPatternMatch patDen denRef
    _ -> matchFail
primitiveDataPatternMatch (PDPlusPat patTerms) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (PolyExprData (Plus terms)) -> do
      -- Pattern variable の場合は [TermExpr] -> [ScalarData] に変換
      let termsCol = if isPatternVar patTerms
                     then Value $ Collection $ Sq.fromList $ map (ScalarData . termExprToScalarData) terms
                     else Value $ Collection $ Sq.fromList $ map TermExprData terms
      termsRef <- lift $ newEvaluatedObjectRef termsCol
      primitiveDataPatternMatch patTerms termsRef
    _ -> matchFail
primitiveDataPatternMatch (PDTermPat patCoeff patMonomials) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (TermExprData (Term coeff monomials)) -> do
      coeffRef <- lift $ newEvaluatedObjectRef (Value (toEgison coeff))
      -- Pattern variable の場合は [(SymbolExpr, Integer)] -> [(ScalarData, Integer)] に変換
      let monomialsCol = if isPatternVar patMonomials
                         then Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [ScalarData (symbolExprToScalarData sym), toEgison exp]) monomials
                         else Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [SymbolExprData sym, toEgison exp]) monomials
      monomialsRef <- lift $ newEvaluatedObjectRef monomialsCol
      (++) <$> primitiveDataPatternMatch patCoeff coeffRef
           <*> primitiveDataPatternMatch patMonomials monomialsRef
    _ -> matchFail
primitiveDataPatternMatch (PDSymbolPat patName patIndices) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Symbol _ name indices)) -> do
      nameRef <- lift $ newEvaluatedObjectRef (Value (String (T.pack name)))
      -- [Index ScalarData]をCollectionに変換
      let indicesCol = Value $ Collection $ Sq.fromList $ map IndexExprData indices
      indicesRef <- lift $ newEvaluatedObjectRef indicesCol
      (++) <$> primitiveDataPatternMatch patName nameRef
           <*> primitiveDataPatternMatch patIndices indicesRef
    _ -> matchFail
primitiveDataPatternMatch (PDApply1Pat patFn patArg) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Apply1 fn arg)) -> do
      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)
      argRef <- lift $ newEvaluatedObjectRef (Value (ScalarData arg))
      (++) <$> primitiveDataPatternMatch patFn fnRef
           <*> primitiveDataPatternMatch patArg argRef
    _ -> matchFail
primitiveDataPatternMatch (PDApply2Pat patFn patArg1 patArg2) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Apply2 fn arg1 arg2)) -> do
      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)
      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))
      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))
      (++) <$> primitiveDataPatternMatch patFn fnRef
           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref
                     <*> primitiveDataPatternMatch patArg2 arg2Ref)
    _ -> matchFail
primitiveDataPatternMatch (PDApply3Pat patFn patArg1 patArg2 patArg3) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Apply3 fn arg1 arg2 arg3)) -> do
      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)
      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))
      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))
      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))
      (++) <$> primitiveDataPatternMatch patFn fnRef
           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref
                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref
                               <*> primitiveDataPatternMatch patArg3 arg3Ref))
    _ -> matchFail
primitiveDataPatternMatch (PDApply4Pat patFn patArg1 patArg2 patArg3 patArg4) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Apply4 fn arg1 arg2 arg3 arg4)) -> do
      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)
      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))
      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))
      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))
      arg4Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg4))
      (++) <$> primitiveDataPatternMatch patFn fnRef
           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref
                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref
                               <*> ((++) <$> primitiveDataPatternMatch patArg3 arg3Ref
                                         <*> primitiveDataPatternMatch patArg4 arg4Ref)))
    _ -> matchFail
primitiveDataPatternMatch (PDQuotePat patExpr) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (Quote expr)) -> do
      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))
      primitiveDataPatternMatch patExpr exprRef
    _ -> matchFail
primitiveDataPatternMatch (PDFunctionPat patName patArgs) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (SymbolExprData (FunctionData name args)) -> do
      nameRef <- lift $ newEvaluatedObjectRef (Value (ScalarData name))
      let argsCol = Value $ Collection $ Sq.fromList $ map ScalarData args
      argsRef <- lift $ newEvaluatedObjectRef argsCol
      (++) <$> primitiveDataPatternMatch patName nameRef
           <*> primitiveDataPatternMatch patArgs argsRef
    _ -> matchFail
primitiveDataPatternMatch (PDSubPat patExpr) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (IndexExprData (Sub expr)) -> do
      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))
      primitiveDataPatternMatch patExpr exprRef
    _ -> matchFail
primitiveDataPatternMatch (PDSupPat patExpr) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (IndexExprData (Sup expr)) -> do
      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))
      primitiveDataPatternMatch patExpr exprRef
    _ -> matchFail
primitiveDataPatternMatch (PDUserPat patExpr) ref = do
  whnf <- lift $ evalRef ref
  case whnf of
    Value (IndexExprData (User expr)) -> do
      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))
      primitiveDataPatternMatch patExpr exprRef
    _ -> matchFail

extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env
extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext (name, ref) _ _ _ _) -> (stringToVar name, ref)) loops

evalMatcherWHNF :: WHNFData -> EvalM Matcher
evalMatcherWHNF (Value matcher@Something) = return matcher
evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher
evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms
evalMatcherWHNF (ITuple refs) = do
  whnfs <- mapM evalRef refs
  ms <- mapM evalMatcherWHNF whnfs
  return $ Tuple ms
evalMatcherWHNF whnf = throwErrorWithTrace (TypeMismatch "matcher" whnf)

--
-- Util
--
toListPat :: [IPattern] -> IPattern
toListPat []         = IInductivePat "nil" []
toListPat (pat:pats) = IInductivePat "::" [pat, toListPat pats]

makeITensorFromWHNF :: Shape -> [WHNFData] -> EvalM WHNFData
makeITensorFromWHNF s xs = do
  xs' <- mapM newEvaluatedObjectRef xs
  return $ ITensor (Tensor s (V.fromList xs') [])

newITensor :: Shape -> [ObjectRef] -> WHNFData
newITensor s refs = ITensor (Tensor s (V.fromList refs) [])

-- Refer the specified tensor index with potential overriding of the index.
refTensorWithOverride :: TensorComponent a b => Bool -> [Index EgisonValue] -> Tensor b -> EvalM a
refTensorWithOverride override js (Tensor ns xs is) =
  tref js' (Tensor ns xs js') >>= tContract' >>= fromTensor
    where
      js' = if override then js else is ++ js

makeBindings :: [Var] -> [ObjectRef] -> EvalM [Binding]
makeBindings vs refs = zipWithM makeBinding vs refs >>= return . concat
  where
    makeBinding :: Var -> ObjectRef -> EvalM [Binding]
    makeBinding v@(Var _ [])    ref = return [(v, ref)]
    makeBinding v@(Var _name is) ref = do
      val <- evalRefDeep ref
      case val of
        TensorData (Tensor _ _ js) -> do
          frame <- pmIndices is js
          return ((v, ref) : frame)
        _ -> throwErrorWithTrace (TypeMismatch "tensor" (Value val))

makeBindings' :: [String] -> [ObjectRef] -> [Binding]
makeBindings' xs = zip (map stringToVar xs)