{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Virgil.Eval where

import qualified Data.Aeson as Ae
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM

import           Language.Virgil.AST

evalCh :: ChValue -> Either String Ae.Value
evalCh (ChObject obj) = Ae.Object `fmap` mapM evalCh obj
evalCh (ChArray arr)  = Ae.Array `fmap` mapM evalCh arr
evalCh (ChString t)   = pure (Ae.String t)
evalCh (ChNumber n)   = pure (Ae.Number n)
evalCh (ChBool b)     = pure (Ae.Bool b)
evalCh ChNull         = pure Ae.Null
evalCh (ChQuote _)    = Left "no evaluation yet"

-- | Match a pattern against a value
match :: Pattern -> Value -> Maybe [(Ident, Value)]
match (PConstr i p) (VConstr i' v)
  | i == i'   = match p v
match (PTup ps) (VTup vs)
  | length ps == length vs =
      fmap concat (sequence [ match p v | p <- ps | v <- vs ])
match (PVar i) x = return [(i, x)]
match (PLit l) (VLit v)
  | l == v = return []
match PUnderscore _ = return []
match _ _ = Nothing

eval :: Env -> Expr -> Either String Value
eval _ (ELit l) = return (VLit l)
eval _ con@(EConstr _) = do
  let fnCase = FnCase { fcPat  = PVar "x"
                      , fcBody = EApp con (EVar "x")
                      }
  return (VLam [fnCase] HM.empty)
eval env (EApp (EConstr i) e) = do
  e' <- eval env e
  return (VConstr i e')
eval env (EApp f x) = do
  VLam cs env' <- eval env f
  arg <- eval env x
  app env cs arg
eval env (EVar v) = case HM.lookup v env of
  Just x  -> Right x
  Nothing -> Left ("Unbound variable: " ++ show v)
eval env (ETup es) = do
  vs <- mapM (eval env) es
  return (VTup vs)
eval env (EList es) = do
  vs <- mapM (eval env) es
  return (foldr (\ x xs -> VConstr "Cons" (VTup [x, xs]))
                (VConstr "Nil" (VTup []))
                vs)
eval env (ERecord rs) = do
  vs <- mapM (eval env . snd) rs
  return (VRecord [ (i, v) | i <- map fst rs | v <- vs ])
eval env (ELam cs) = return (VLam cs env)
eval env (ETyped e _) = eval env e
eval env (EAccess e i) = do
  VRecord r <- eval env e
  case lookup i r of
    Just v  -> return v
    Nothing -> Left ("Bad lookup: field " ++ show i ++
                     " in " ++ show r)

extend :: Env -> [(Ident, Value)] -> Env
extend = foldr (uncurry HM.insert)

app :: Env -> [FnCase] -> Value -> Either String Value
app _ [] _ = Left "Non-exhaustive cases"
app env (c:cs) arg = case match (fcPat c) arg of
  Just bindings -> eval (extend env bindings) (fcBody c)
  Nothing       -> app env cs arg