--
-- (c) 2012 Wei Ke
--      license:          GPL-3
--      license-file:     LICENSE
--
-- |
-- The "Env" module defines the environment graph 'R', 
-- the built-in function implementation table 'builtInFunTab', 
-- with optional program argument reading functions in table 'builtInFunTabWithArgs',
-- and 'consEnv' to construct the environment graph.
--
module Env ( FunImpTab, builtInFunTab, builtInFunTabWithArgs
           , R(..), consEnv
           )

where

import Data.Char
import Data.Maybe
import Data.List

import ErrMsg
import Graph
import RgAS
import Ty

type FunImpTab = [(String, [N] -> ErrMsg N)]

--
-- built-in functions
--

builtInFunTab :: FunImpTab
builtInFunTab = 
        [ ("eqInt",     \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VBool (x == y)))
                                _ -> fail "illegal arguments")
        , ("gtInt",     \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VBool (x > y)))
                                _ -> fail "illegal arguments")
        , ("ltInt",     \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VBool (x < y)))
                                _ -> fail "illegal arguments")
        , ("eqTxt",     \ns -> case ns of
                                [NV (VTxt x), NV (VTxt y)] -> return (NV (VBool (x == y)))
                                _ -> fail "illegal arguments")
        , ("gtTxt",     \ns -> case ns of
                                [NV (VTxt x), NV (VTxt y)] -> return (NV (VBool (x > y)))
                                _ -> fail "illegal arguments")
        , ("ltTxt",     \ns -> case ns of
                                [NV (VTxt x), NV (VTxt y)] -> return (NV (VBool (x < y)))
                                _ -> fail "illegal arguments")
        , ("eqObj",     \ns -> case ns of
                                [NV VNull, NV VNull] -> return (NV (VBool True))
                                [NV VNull, NO _] -> return (NV (VBool False))
                                [NO _, NV VNull] -> return (NV (VBool False))
                                [NO x, NO y] -> return (NV (VBool (x == y)))
                                _ -> fail "illegal arguments")
        , ("add",       \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VInt (x + y)))
                                _ -> fail "illegal arguments")
        , ("sub",       \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VInt (x - y)))
                                _ -> fail "illegal arguments")
        , ("mul",       \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VInt (x * y)))
                                _ -> fail "illegal arguments")
        , ("div",       \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VInt (x `div` y)))
                                _ -> fail "illegal arguments")
        , ("mod",       \ns -> case ns of 
                                [NV (VInt x), NV (VInt y)] -> return (NV (VInt (x `mod` y)))
                                _ -> fail "illegal arguments")
        , ("cat",       \ns -> case ns of 
                                [NV (VTxt x), NV (VTxt y)] -> return (NV (VTxt (x ++ y)))
                                _ -> fail "illegal arguments")
        , ("take",      \ns -> case ns of 
                                [NV (VInt x), NV (VTxt y)] -> return (NV (VTxt (genericTake x y)))
                                _ -> fail "illegal arguments")
        , ("drop",      \ns -> case ns of 
                                [NV (VInt x), NV (VTxt y)] -> return (NV (VTxt (genericDrop x y)))
                                _ -> fail "illegal arguments")
        , ("lower",     \ns -> case ns of 
                                [NV (VTxt x)] -> return (NV (VTxt (map toLower x)))
                                _ -> fail "illegal arguments")
        , ("upper",     \ns -> case ns of 
                                [NV (VTxt x)] -> return (NV (VTxt (map toUpper x)))
                                _ -> fail "illegal arguments")
        , ("and",       \ns -> case ns of
                                [NV (VBool x), NV (VBool y)] -> return (NV (VBool (x && y)))
                                _ -> fail "illegal arguments")
        , ("or",        \ns -> case ns of
                                [NV (VBool x), NV (VBool y)] -> return (NV (VBool (x || y)))
                                _ -> fail "illegal arguments")
        , ("imp",        \ns -> case ns of
                                [NV (VBool x), NV (VBool y)] -> return (NV (VBool (not x || y)))
                                _ -> fail "illegal arguments")
        , ("eqv",       \ns -> case ns of
                                [NV (VBool x), NV (VBool y)] -> return (NV (VBool (x == y)))
                                _ -> fail "illegal arguments")
        , ("not",       \ns -> case ns of
                                [NV (VBool x)] -> return (NV (VBool (not x)))
                                _ -> fail "illegal arguments")
        , ("parseInt",  \ns -> case ns of
                                [NV (VTxt x)] -> case reads x :: [(Integer, String)] of
                                    [(y, [])] -> return (NV (VInt y))
                                    _ -> fail "invalid integer format"
                                _ -> fail "illegal arguments")
        , ("toTxtInt",  \ns -> case ns of
                                [NV v@(VInt _)] -> return (NV (VTxt (show v)))
                                _ -> fail "illegal arguments")
        , ("toTxtBool", \ns -> case ns of
                                [NV v@(VBool _)] -> return (NV (VTxt (show v)))
                                _ -> fail "illegal arguments")
        ]

builtInFunTabWithArgs :: [String] -> FunImpTab
builtInFunTabWithArgs args = argv:argc:builtInFunTab where
    argv = (argvName,   \ns -> case ns of 
                            [NV (VInt i)] -> do 0 <= i && i < toInteger (length args) |? "index out of range" 
                                                return (NV (VTxt (args !! fromIntegral i)))
                            _ -> fail "illegal arguments")
    argc = (argcName,   \ns -> case ns of
                            [] -> return (NV (VInt (toInteger (length args))))
                            _ -> fail "illegal arguments")

data R = R Ns Es [(N, Ns)] deriving Show

mk :: P_ -> H -> N -> La -> K_
mk p@(P_ mds _) h t m =
        case find (\(tx, mx, _) -> tx == t && mx == m) [(NC cl, LA a, k) | (cl, a, k) <- mds] of
            Just (_, _, k) -> k
            _ -> 
                case gecls h t of
                    Just t' -> mk p h t' m
                    _ ->
                        let Just t' = findTgH h t isaLa
                        in  mk p h t' m

insE :: [Ssti N] -> H -> Ep_ -> (H, Ep_)
insE sst h (Cast_ t ep) =
        let (h', t') = reuseInsT sst h t
            (h'', ep') = insE sst h' ep
        in (h'', Cast_ t' ep')
insE sst h (Attr_ ep a) =
        let (h', ep') = insE sst h ep
        in  (h', Attr_ ep' a)
insE sst h (App_ s eps) =
        let (h', eps') = mapAccumL (insE sst) h eps
        in  (h', App_ s eps')
insE _ h ep = (h, ep)

insK :: [Ssti N] -> H -> K_ -> (H, K_)
insK sst h (New_ u ep) =
        let (h', u') = reuseInsT sst h u
            (h'', ep') = insE sst h' ep
        in (h'', New_ u' ep')
insK sst h (Decl_ tps) =
        let (ts, xs) = unzipTps_ tps
            (h', ts') = mapAccumL (reuseInsT sst) h ts
        in  (h', Decl_ (zipTps_ ts' xs))
insK sst h (Assign_ ep1 ep2) =
        let (h', [ep1', ep2']) = mapAccumL (insE sst) h [ep1, ep2]
        in  (h', Assign_ ep1' ep2')
insK sst h (Invk_ ep m vs xs cas rs) =
        let (h1, ep':vs') = mapAccumL (insE sst) h (ep:vs)
            (h2, rs') = mapAccumL (insE sst) h1 rs
            (h3, cas') = mapAccumL insCam h2 cas
        in  (h3, Invk_ ep' m vs' xs cas' rs') where
    insCam hx Nothing = (hx, Nothing)
    insCam hx (Just t) = let (h', t') = reuseInsT sst hx t in (h', Just t')
insK sst h (Seq_ k1 k2) =
        let (h', [k1', k2']) = mapAccumL (insK sst) h [k1, k2]
        in  (h', Seq_ k1' k2')
insK sst h (If_ ep k1 k2) = 
        let (h', ep') = insE sst h ep
            (h'', [k1', k2']) = mapAccumL (insK sst) h' [k1, k2]
        in  (h'', If_ ep' k1' k2')
insK sst h (While_ ep k) = 
        let (h', ep') = insE sst h ep
            (h'', k') = insK sst h' k
        in  (h'', While_ ep' k')
insK sst h (Print_ eol eps) = 
        let (h', eps') = mapAccumL (insE sst) h eps
        in  (h', Print_ eol eps')
insK _ h k = (h, k)

consEnv :: VisTab -> P_ -> H -> R
consEnv viss p h0 = cons0 h0 empty empty where
    
    cons0 h@(H hns hes) rns res = if ts == [] then cons2 h rns res else cons1 h rns' res' ts where
        (rns', res') = 
                foldl ( \(nsx, esx) t -> 
                        let Just (G _ ces r) = clo hes t
                            el = [E t la (ini n) | E _ la@(LA _) n <- getOutEdges ces r]
                        in  (nsx +. t +../ [l | E _ _ l <- el], esx +../ el)) (rns, res) ts
        ts = [t | t <- toList (hns -.. rns), isTy hes t && isCc h t]
                
    cons1 h rns res ts = cons0 h'' rns'' res'' where
        (h'', rns'', res'') = 
                foldl ( \(hx, nsx, esx) (t, s) -> 
                        let Just (G _ ces r) = cloH hx t
                            Just cs = findTg ces r staLa
                            ms = getOutLas ces cs
                            sst = ssj hx t
                            (h', rns', res') = 
                                    foldl ( \(hy, nsy, esy) m -> 
                                            let (hy', k) = insK sst hy (mk p hy t m)
                                                nk = NK k
                                            in  (hy', (nsy +. nk), (esy +. E s m nk))) (hx, nsx +. s, esx +. E t staLa s) ms
                        in  (h', rns', res')) (h, rns, res) ps
        ps = [(t, getSta h t) | t <- ts] 
                
    cons2 h@(H hns hes) rns res = R rns res rsm where
        rsm = foldl (\smx (t, s) -> 
                     let sups = fromList [sup | sup <- ts, sup == t || subty viss h t sup]
                     in  (s, sups):smx) [] ps
        ps = [(t, fromJust m) | t <- toList rns, let m = findTg res t staLa, isJust m]
        ts = [t | t <- toList hns, isTy hes t]

--
-- end of Env
--
-- --$Id: Env.hs 1188 2012-11-13 16:27:51Z wke@IPM.EDU.MO $