{----
 - Evaluation.hs - evaluation logic for the noodle programming language
 ----
 - Author: Jesse Rudolph <jesse.rudolph@gmail.com>
 - See LICENSE for licensing details
 ----------------------------------------------------------------- -}

module Language.Noodle.Evaluation
    ( compile
    , compileFile
    , compute
    , declare
    , extfun
    , extop
    , extenv
    , extmod
    , showAst
    , rtError
    , srtError
    , Error(BadParse)
    , Env(..)
    , Name
    , Val(..)) where

import System.FilePath
import Data.Unique
import Data.Maybe
import Data.Ratio
import Data.Dynamic

import Language.Noodle.Syntax
import Language.Noodle.Parsing.String
import Language.Noodle.Parsing.Noodle
import Language.Noodle.DepTree

instance Show Val where
    show (Function _) = "<function>"
    show (Error e)    = show e
    show (Number i)   = let n = numerator i
                            d = denominator i
                        in if (d == 1) 
                              then show n
                              else show n ++ "/" ++ show d
    show (Module _)   = "<module>"
    show (Symbol s)   = s
    show (Str s)      = show s
    show (Thunk _)    = "<Thunk (this should never be reachable)>"
    show (Prod v1 v2) = "(" ++ show v1 ++ "," ++ subprod v2 ++ ")" where
        subprod (Prod v v2) = show v ++ "," ++ subprod v2
        subprod v           = show v
    show (Extern _)   = "<haskell value>"
    show (Abst _ _)   = "<abstract>"
    show (Nil)        = "nil"

type Name = String
data Val
    = Function (Val -> IO Val)
    | Thunk (IO Val)
    | Module (IO Env)
    | Error Error
    | Number Rational
    | Symbol String
    | Str String
    | Prod Val Val
    | Extern Dynamic
    | Abst (Maybe Unique) Val
    | Nil

data Error
    = RtErr Val
    | ErrAt String Error -- stacktrace of error
    | HeadMatch
    | MDMod
    | MDDiffForm
    | NotDef String
    | WithNoMod
    | ModRefFail String
    | DepLoadFail String String
    | PatFail Pattern
    | BadParse String Int Int String

instance Show Error where
    show (ErrAt s e) = "   in " ++ s ++ ":\n" ++ show e
    show (RtErr v)   = "   " ++ show v
    show (HeadMatch) =
        "   non-exhaustive pattern match in declaration head"
    show (MDMod) =
        "   you can only declare a module once"
    show (MDDiffForm) =
        "   mult-declarations must all have the same form"
    show (NotDef n)   =
        "   referenced undefined identifier '" ++ n ++ "'"
    show (WithNoMod) =
        "   with clause used with non-module value"
    show (ModRefFail n) =
        "   module reference '" ++ n ++ "' applied to non-module value"
    show (DepLoadFail dep reason) =
        "   dependency '" ++ dep ++ "' failed to load with reason:\n" ++
        "   " ++ reason
    show (PatFail p) =
        "   pattern '" ++ show p ++ "' failed to match right had side of clause"
    show (BadParse input line pos message) =
        "   parse error on line " ++ show line ++ ":\n" ++
        "    " ++ getline line (lines input) ++ " - " ++ message ++ "\n" ++
        "    " ++ pointer pos ++ "\n\n"
        where
            getline 1 (l:ls) = l
            getline n (l:ls) = getline (n-1) ls
            pointer 1 = "^"
            pointer n = " " ++ pointer (n-1)



-- helper functions for generating error from evaluator and
-- native libraries
rtError :: Val -> Val
rtError v = Error $ RtErr v
srtError s = rtError $ Str s

hmError :: Val
hmError = Error HeadMatch

errAt   :: String -> Error -> Val
errAt s e = Error $ ErrAt s e

unwindErr :: Error -> Error
unwindErr (ErrAt n e) = unwindErr e
unwindErr other       = other



instance Eq Val where
    (Number i1) == (Number i2)       = i1 == i2
    (Symbol s1) == (Symbol s2)       = s1 == s2
    (Str s1)    == (Str s2)          = s1 == s2
    (Nil)       == (Nil)             = True
    (Prod v11 v12) == (Prod v21 v22) = (v11 == v21) && (v12 == v22)
    _              == _              = False

data Env
    = Env Unique Env [(Name, Val)]
    | Bar Env -- abstraction barrier that keeps enclosing environments from inheriting abstraction value
    | Top

instance Eq Env where -- kludged in so that we can scan a list of (Maybe Env) for Nothing
    e == e2 = True

-- retrieve the value associated with some name in the environment if it has been declared
nlookup :: Env -> Name -> Val
nlookup Top n = Error $ NotDef n
nlookup (Env _ next table) n
    = case lookup n table of
        Just v  -> v
        Nothing -> nlookup next n
nlookup (Bar e) n = nlookup e n

-- used by the interpreter to construct functions from their specification
funbuild :: String -> Env -> Pattern -> (Env -> IO Val) -> Val
funbuild n e p f = Function (\v -> do menv <- match e p v
                                      case menv of
                                           Just e2 -> f e2
                                           Nothing -> return $ errAt n HeadMatch)


-- combinators to build noodle functions from haskell IO Computations

extfun :: (Val -> IO Val)        -> Val
extop  :: (Val -> Val -> IO Val) -> Val
extfun f = Function f
extop f = Function (\v -> return $ Function (\v2 -> f v v2))

-- wrap a list of (name,val) tuples in a generally
-- useful noodle environment construction.

extenv :: [(String,Val)] -> Env
extenv ds = Bar $ Env undefined Top ds

extmod :: Env -> Val
extmod e  = Module $ return e

-- declaration evaluator
declare :: Env -> Decls -> IO (Either String Env)
declare e (Decls ds) =
    do u   <- newUnique
       let fds = (sanity $ composeDecs $ makeblock e u
                    (case fds of
                          Left s    -> [("error",srtError s)]
                          Right vds -> vds)
                  ds )
        in case fds of
                Right declist -> return $ Right $ Bar $ Env u e declist
                Left s        -> return $ Left s
     where
           -- check to see if any of the values in the environment are error values
           sanity []            = Right []
           sanity ((_,Error err):_) = Left (show err)
           sanity (d:ds)    = case sanity ds of
                                   Left s    -> Left s
                                   Right dds -> Right (d:ds)
           -- construct a list of mutually recursive declarations
           makeblock e u vds ds = declist where
               thisEnv  = Env u e vds
               declist  = map declare' ds
               declare' (IntThunk n c)
                   = (n, Thunk ( do r <- compute thisEnv c
                                    return $ case r of
                                                  Error err -> errAt n err
                                                  v       -> v))
               declare' (IntFun p n c)
                   = (n, funbuild n thisEnv p
                      (\newenv -> do r <- compute newenv c
                                     return $ case r of
                                                   Error err -> errAt n err
                                                   v      -> v))
               declare' (IntMod n modecls)
                   = (n,Module $ (do eenv <- declare thisEnv modecls
                                     case eenv of
                                          Left  s -> fail $
                                           "   in module '" ++ n ++ "':\n   " ++ s
                                          Right e -> return e))
               declare' (IntOp p1 n p2 c)
                   = (n, funbuild n thisEnv p2
                      (\newenv -> return $ funbuild n newenv p1
                       (\nnenv -> do r <- compute nnenv c
                                     return $ case r of
                                                   Error err -> errAt n err
                                                   v       -> v)))
               -- try to combine declarations with the same name into a single declaration
           composeDecs :: [(String,Val)] -> [(String,Val)]
           composeDecs [] = []
           composeDecs [d] = [d]
           composeDecs (cur@(name,val1):rest)
            = let restc     = composeDecs rest
                  matchesMe = lookup name restc
                  restcSans  = filter (\(n,_) -> n /= name) restc
              in case matchesMe of
                      Nothing -> cur:restc
                      Just val2 -> (name,composeDecVals val1 val2):restcSans
           -- try to seqence computational values, halting sequencing at success
           -- (only if the first computation fails is the second evaluated)
           composeDecVals (Thunk a1) (Thunk a2) = Thunk $
                do firstVal <- a1
                   case firstVal of
                        Error e -> let err = unwindErr e
                                   in case err of
                                           RtErr _ -> a2
                                           _       -> return firstVal
                        _       -> return firstVal
           composeDecVals (Function f1) (Function f2) = Function $
               \arg ->
                    do firstVal <- f1 arg
                       case firstVal of
                            Error e -> let err = unwindErr e
                                       in case err of
                                               HeadMatch -> f2 arg
                                               _         -> return firstVal
                            _       -> return firstVal
           composeDecVals (Module _) (Module _) = Error MDMod
           composeDecVals (Error e) _ = Error e -- composing errors should resolve to the first
           composeDecVals _ (Error e) = Error e
           composeDecVals _ _         = Error MDDiffForm   -- composing anything other than the above is nonsense




   -- pattern matching
match :: Env -> Pattern -> Val -> IO (Maybe Env)
match e (Pat (Ident s)) v
    = case e of
           (Env u _ _) -> return $ Just $ Env u e [(s,v)]
           (Bar e2)    -> do u <- newUnique
                             return $ Just $ Env u e2 [(s,v)]
           (Top)       -> do u <- newUnique
                             return $ Just $ Env u e [(s,v)]
match e (Pat (Numb  i)) (Number r)
    = return $ if (toRational i) == r
                  then Just e
                  else Nothing
match e (Pat (Symb s)) (Symbol s2)
    = return $ if s == s2
                  then Just e
                  else Nothing
match e (Pat (StrLit s)) (Str s2)
    = return $ if s == s2
               then Just e
               else Nothing
match e@(Env u _ _) (Pat (Abs p)) (Abst mu v)
    = case mu of
           Nothing -> return Nothing
           Just u2 ->
                if u == u2
                   then match e p v
                   else return $ Nothing
match e (Pat (ProdLit p1 p2 [])) (Prod v1 v2)
    = do menva <- match e p1 v1
         menvb <- match e p2 v2
         case (menva,menvb) of
              (Just e,Just (Env u _ ds)) -> return $ Just (Env u e ds)
              (Nothing,_)                -> return Nothing
              (_,Nothing)                -> return Nothing
match e (Pat (ProdLit p1 p2 ps)) (Prod v1 v2)
    = do if length vals /= length pats
            then return Nothing
            else do menvs <- sequence $ zipWith (match e) pats vals
                    if Nothing `elem` menvs
                       then return Nothing
                       else let envs = map fromJust menvs
                            in return $ Just $ foldr foldenv e envs
    where foldenv e (Env u _ ds) = (Env u e ds)
          foldenv e (Bar _)      = e
          foldenv e Top          = e
          pats = p1:p2:ps
          vals = v1 : unprod v2
          unprod (Prod vv vvs) = vv : unprod vvs
match e (Pat (Paren p)) v
    = match e p v
match _ _ _ = return Nothing

-- computation evaluator
compute :: Env -> Comp -> IO Val
compute e (In ds c)
    = do eenv <- declare e ds
         case eenv of
              Left s -> return $ srtError s
              Right env -> compute env c
compute e (With cm c) =
    do v <- compute e cm
       case v of
            (Module doenv) ->
                do env <- doenv
                   compute (case env of
                                 (Bar (Env u _ ds)) -> (Bar (Env u e ds))
                                 (Top)              -> error "Module should never reference TOP (bug)"
                                 (Env u _ ds)       -> (Bar (Env u e ds))) c -- this shouldnt be reachable either
            Error err        -> return $ Error err
            other          -> return $ Error WithNoMod
compute e (PatMatch p c1 c2)
    = do c1v <- compute e c1
         menv <- match e p c1v
         case menv of
              Just e2 -> compute e2 c2
              Nothing -> return $ Error $ PatFail p
compute e (Handler handler c2)
    = do val <- compute e c2
         case val of
              Error err -> handle err handler val
              _         -> return val
    where
        -- unwind the stack-trace and apply the handler to the error
        handle (ErrAt _ err) handler val = handle err handler val
        handle (RtErr v)     handler val
            = do hval <- compute e handler
                 case hval of
                      (Function f) -> f v
                      _            -> return hval

        handle _ _ val  = return val -- dont handle evaluation errors
compute e (ExprComp ex)
    = eval e ex


-- expression evaluator
eval :: Env -> Expr -> IO Val
eval e (ExprApp e1 e2)
    = do arg <- eval e e1
         case arg of
            Error s -> return $ Error s
            _       ->
                do fun <- eval e e2
                   case fun of
                        Function f -> f arg
                        other      -> return fun
eval e (ExprOp e1 o e2)
    = case nlookup e o of                                  --make sure the operator exists
           Error err    -> return $ Error err
           Function f ->
            do v1 <- eval e e1                             -- evaluate the first arg
               case v1 of
                    Error err -> return $ Error err
                    _       ->
                     do vf <- f v1
                        case vf of                           -- if vf is...
                             Error err     -> return $ Error err -- an error- fail
                             Function f2 ->                  -- a function
                              do v2 <- eval e e2             -- apply to second arg
                                 case v2 of
                                      Error err     -> return $ Error err
                                      _           -> f2 v2
                             notfunction -> return vf        -- if not, do not evaluate second arg, and return vf
           other          ->
            do _  <- eval e e1 -- the operator id didnt reference a function, eval first arg
               return other    -- and return the operator val
eval e (Lit l)    = expand e l
eval e (ModRef s) = return $ extfun mref where
    mref (Module doenv) = do env <- doenv
                             case nlookup env s of
                                  Thunk io -> io -- make sure modrefs reduce thunks
                                  other    -> return other
    mref _              = return $ Error $ ModRefFail s


-- literal evaluator
expand :: Env -> Literal Comp -> IO Val
expand e (Numb i)   = return $ Number (i % 1)
expand e (Ident s)  = case nlookup e s of
                           (Thunk io) -> io
                           other      -> return other
expand e (Symb s)   = return $ Symbol s
expand e (StrLit s) = return $ Str s
expand e (ProdLit c1 c2 (c:cs))
    = do v    <- compute e c1
         rest <- expand e (ProdLit c2 c cs)
         return $ Prod v rest
expand e (Abs c)
    = do  v <- compute e c
          case e of
               (Env u _ _) -> return $ Abst (Just u) v
               (Bar _)     -> return $ Abst Nothing v
               (Top)       -> return $ Abst Nothing v
expand e (ProdLit c1 c2 [])
    = do v1 <- compute e c1
         v2 <- compute e c2
         case (v1,v2) of
              (Error s,_) -> return $ Error s
              (_,Error s) -> return $ Error s
              _           -> return $ Prod v1 v2
expand e (Paren c)  = compute e c




-- parse the body of a source file
modl :: NParser Decls
modl = do m <- topDecls
          notcode
          inputEnd
          return m

-- try to parse, and convert parse errors to error values on parse failure,
-- otherwise evaluate the parse result.
compileFile :: Env -> FilePath -> IO Val
compileFile e fp
    = do eSf <- parseDeps [] fp
         case eSf of
              Left  s -> return $ srtError s
              Right src -> compileFile' e src

compileFile' :: Env -> SourceFile -> IO Val
compileFile' e src
    = do let name = srcName src
             dir  = srcDir src
             body = srcBody src
             deps = srcDeps src
         mods  <- mapM (compileFile' e) deps
         eenvs <- valsToEnvs mods
         case eenvs of
              Left s -> return $ Error $ DepLoadFail name s
              Right envs -> do let newenv = squashEnvs (reverse (e:envs))
                                   prog   = compile newenv body
                               case prog of
                                    Error err -> return $ errAt ("file " ++ name) err
                                    v       -> return v
    where
        squashEnvs []              = Top
        squashEnvs (Env u _ ds:es) = Bar $ Env u (squashEnvs es) ds
        squashEnvs (Bar e:es)      = squashEnvs (e:es)
        squashEnvs (Top:es)        = squashEnvs es

        valsToEnvs :: [Val] -> IO (Either String [Env])
        valsToEnvs []          = return $ Right $ []
        valsToEnvs (v:vs)
            = case v of
                   Error err -> return $ Left $ "this shouldnt happen: " ++ (show err)
                   Module ioe ->
                     do e <- ioe
                        ees <- valsToEnvs vs
                        case ees of
                             Left s   -> return $ Left s
                             Right es -> return $ Right (e:es)
                   _  -> return $ Left $
                           "somehow one of the dependencies in '" ++ (srcName src) ++
                           "' resolved to something other than a module (bug)"

   -- build a module from the headerless body of a source file and its enclosing environment
compile :: Env -> String -> Val
compile e input
    = case parsed of
           Failure s ((_,rel,line),_)     ->  Error $ BadParse input line rel s
           Success res _ _ ->
            Module $ do eenv <- declare e res
                        case eenv of
                             Left s    -> error s
                             Right env -> return env
    where
        parsed = runp modl (startPos,()) input


-- display source parenthetically (mainly useful for showing precedence binding)
showAst :: String -> String
showAst input
    = case parsed of
           Failure s _     -> s
           Success res _ _ ->
            case res of
                 Left p  -> show p
                 Right m -> show m

    where
        -- TODO: make a parser that check for end of input over a comp.
        parsed = runp (pEither comp modl) (startPos,()) input