--
-- (c) 2012 Wei Ke
--      license:          GPL-3
--      license-file:     LICENSE
--
-- |
-- The "RgAS" module defines the /rCOSg/ abstract syntax,
-- and the built-in function signatures.
-- Functions to fix the abstract syntax tree are also defined.
-- These fixes are easier to be done after the entire program has been parsed.
--

module RgAS ( Program'(..)
            , Program(..)
            , Cdecl(..)
            , XSpec(..)
            , Adef(..)
            , Vis(..)
            , Mdef(..)
            , Typing(..), unzipTps
            , Te(..), isTNomin, isTX, isCe
            , Ssti(..), Sst, zipSst, unzipSst, lookupSst
            , Cmd(..), showPartCmd
            , Ep(..), isLE
            , Mainm(..)
            , A_(..), D_(..), U_(..), X_(..), V_(..)
            , Fun(..), FunTab
            , argcName, argvName
            , fixPrg', fixMainCmd'
            )
        
where

import Data.List

import ErrMsg
import Misc

--
-- rCOS/g abstract syntax
--
-- |
-- unfixed programs, 
-- 
-- need to fix function signatures in applications, and
-- need to fix type variables in type expressions. 
--

data Program'   = Program' [Fun] [Cdecl] Mainm 

--
-- |
-- programs
--

data Program    = Program [Cdecl] Mainm

--
-- |
-- class declarations
--

data Cdecl      = Cdecl U_ [XSpec] (Maybe Te) [Adef] [Mdef]

--
-- |
-- type variable specifictions
--

data XSpec      = XSpec X_ (Maybe Te) (Maybe Te)

--
-- |
-- attribute definitions
--

data Adef       = Adef Vis Typing

--
-- |
-- visibilities
--

data Vis        = Priv 
                | Prot
                | Pub
    deriving (Eq, Ord)
    
instance Show Vis where
    show Priv = "priv."
    show Prot = "prot."
    show Pub  = "pub."    
    
--
-- |
-- method definitions
--

data Mdef       = Mdef A_ [Typing] Cmd

--
-- |
-- typings
--

data Typing     = Typing Te A_

unzipTps                   :: [Typing] -> ([Te], [A_])
unzipTps (Typing te x:tps) =  (te:tes, x:xs) where (tes, xs) = unzipTps tps
unzipTps _                 =  ([], [])

instance Show Typing where
    show (Typing te (A_ s)) = show te ++ " " ++ s 

--
-- |
-- type expressions
--

data Te         = TP D_             -- ^ primitive types 
                | TC U_             -- ^ generic and non-generic classes
                | TX X_             -- ^ type variables
                | TCn [Te]          -- ^ class conjunctions
                | TCj U_ [Ssti Te]  -- ^ class instantiations
        
instance Eq Te where
    TP x == TP y = x == y
    TC x == TC y = x == y
    TX x == TX y = x == y
    TCn x == TCn y = setEq x y
    TCj clx x == TCj cly y = clx == cly && setEq (rmIds x) (rmIds y) where
        rmIds ss = [i | i@(l :- r) <- ss, l /= r]
    _ == _ = False

instance Show Te where
    show (TP INT)       = "Int"
    show (TP BOOL)      = "Bool"
    show (TP TXT)       = "Txt"
    show (TP NULL)      = "NIL"
    show (TP WILD)      = "_"
    show (TC (U_ s))    = s
    show (TX (X_ _ s))  = "\'" ++ s
    show (TCn x)        = "&(" ++ showElems x ++ ")"
    show (TCj (U_ s) x) = s ++ "<" ++ showElems x ++ ">"
    
isTNomin :: Te -> Bool
isTNomin (TP _) = True
isTNomin (TC _) = True
isTNomin (TX _) = True
isTNomin _      = False

isTX :: Te -> Bool
isTX (TX _) = True
isTX _      = False

isCe :: Te -> Bool
isCe (TP _) = False
isCe _      = True

--
-- |
-- type substitution items (mappings):
-- between type expressions or type nodes
--

data Ssti a     = a :- a deriving Eq

type Sst a      = [Ssti a]      -- ^ type substitutions

instance (Eq a, Show a) => Show (Ssti a) where
     show (x :- y) = (show x) ++ ":-" ++ (show y) 

zipSst :: Eq a => [a] -> [a] -> Sst a
zipSst (x:xs) (y:ys) =  x :- y:(zipSst xs ys)
zipSst _ _           =  []

unzipSst :: Eq a => Sst a -> ([a], [a])
unzipSst (x :- y:sst) =  (x:xs, y:ys) where (xs, ys) = unzipSst sst
unzipSst _            =  ([], [])

lookupSst :: Eq a => Sst a -> a -> Maybe a
lookupSst (x :- y:ps) x' 
    |   x == x'   = Just y
    |   otherwise = lookupSst ps x'
lookupSst _ _     = Nothing

--
-- |
-- commands
--

data Cmd        = Skip
                | Decl [Typing]
                | End [A_]
                | New Te Ep
                | Assign Ep Ep
                | Invk Ep A_ [Ep] [A_] [Maybe Te] [Ep]
                | Seq Cmd Cmd
                | If Ep Cmd Cmd
                | While Ep Cmd
                | Print Bool [Ep]
         
instance Show Cmd where
    show Skip            = "skip;"
    show (Decl tps)      = "var " ++ showElems tps ++ ";"
    show (End s)         = "end " ++ showElems s ++ ";"
    show (New te ep)     = show te ++ ".new(" ++ show ep ++ ");"
    show (Assign ep ep') = show ep ++ " := " ++ show ep' ++ ";"
    show (Invk ep (A_ s) vs xs cas rs) 
                         = show ep ++ "." ++ s ++ "(" ++ showElems vs ++ " : " ++ showParCasts (zip xs cas) ++ " : " ++ showElems rs ++ ");"
    show k@(Seq _ _)     = "{ " ++ showCmdList (flattenSeq k) ++ " }"
    show (If ep k k')    = "if ( " ++ show ep ++ " ) " ++ show k ++ " else " ++ show k'
    show (While ep k)    = "while ( " ++ show ep ++ " ) " ++ show k 
    show (Print eol eps) = "print " ++ showElems eps ++ if eol then "" else "," ++ ";" 

showParCasts :: [(A_, Maybe Te)] -> String
showParCasts [] = ""
showParCasts [(x, Nothing)] = show x
showParCasts [(x, Just te)] = show x ++ " (" ++ show te ++ ")"
showParCasts (x:xs) = showParCasts [x] ++ "," ++ showParCasts xs

showPartCmd :: Cmd -> String
showPartCmd k@(Seq _ _) = "{ " ++ showPartCmdList (flattenSeq k) ++ " }"
showPartCmd (If ep k k') = "if ( " ++ show ep ++ " ) " ++ showPartCmd k ++ " else " ++ showPartCmd k'
showPartCmd (While ep k) = "while ( " ++ show ep ++ " ) " ++ showPartCmd k
showPartCmd k = show k

showCmdList :: [Cmd] -> String
showCmdList [] = ""
showCmdList [k] = show k
showCmdList (k:ks) = show k ++ " " ++ showCmdList ks

showPartCmdList :: [Cmd] -> String
showPartCmdList [] = ""
showPartCmdList [k] = show k
showPartCmdList (k:_) = show k ++ " ..."

flattenSeq :: Cmd -> [Cmd]
flattenSeq (Seq k k') = flattenSeq k ++ flattenSeq k'
flattenSeq k = [k]

--
-- |
-- expressions
--

data Ep         = Self
                | Lit V_
                | App Fun [Ep]
                | Var A_
                | Attr Ep A_
                | Cast Te Ep
                | Wild

instance Show Ep where
    show Self               = "*self"
    show (Lit x)            = show x
    show (App fn xs)        = show fn ++ " " ++ show xs
    show (Var (A_ s))       = s
    show (Attr ep (A_ s))   = show ep ++ "." ++ s
    show (Cast te ep)       = "(" ++ show te ++ ") " ++ show ep
    show Wild               = "_"
         
isLE :: Ep -> Bool
isLE Wild       = True
isLE (Var _)    = True
isLE (Attr _ _) = True
isLE _          = False

--
-- |
-- main method definitions
--
       
data Mainm      = Mainm [Typing] Cmd

--
-- |
-- attribute/variable/method names
--

data A_         = A_ String deriving (Eq, Ord)

instance Show A_ where
    show (A_ s) = s

--
-- |
-- data type (primitive type) names
--

data D_         = INT 
                | BOOL 
                | TXT 
                | NULL
                | WILD
    deriving (Eq, Ord)

--
-- |
-- user class names
--

data U_         = U_ String deriving (Eq, Ord)

instance Show U_ where
    show (U_ s) = s

--
-- |
-- type variable names
--

data X_         = X_ U_ String deriving (Eq, Ord)

--
--
-- literal values
--

data V_         = VInt Integer
                | VBool Bool
                | VTxt String
                | VNull
    deriving (Eq, Ord)

instance Show V_ where
    show (VInt x)       = show x
    show (VBool False)  = "false"
    show (VBool True)   = "true"
    show (VTxt x)       = show x
    show VNull          = "null"

--
-- |
-- built-in functions
--

data Fun        = Fun String [Te] Te deriving Eq

-- | 
-- signature tables of built-in functions 
type FunTab     = [Fun]

-- |
-- tables of type variables
type XTab       = (U_, [String])

instance Show Fun where
    show (Fun s ptes rte) = s ++ show ptes ++ "->" ++ show rte

argvName :: String
argvName = "argv"

argcName :: String
argcName = "argc"

builtInFuns :: FunTab
builtInFuns =
        [ Fun argvName      [TP INT] (TP TXT)
        , Fun argcName      [] (TP INT)
        , Fun "eqInt"       [TP INT, TP INT] (TP BOOL)
        , Fun "gtInt"       [TP INT, TP INT] (TP BOOL)
        , Fun "ltInt"       [TP INT, TP INT] (TP BOOL)
        , Fun "eqTxt"       [TP TXT, TP TXT] (TP BOOL)
        , Fun "gtTxt"       [TP TXT, TP TXT] (TP BOOL)
        , Fun "ltTxt"       [TP TXT, TP TXT] (TP BOOL)
        , Fun "eqObj"       [emptyInterface, emptyInterface] (TP BOOL)
        , Fun "add"         [TP INT, TP INT] (TP INT)
        , Fun "sub"         [TP INT, TP INT] (TP INT)
        , Fun "mul"         [TP INT, TP INT] (TP INT)
        , Fun "div"         [TP INT, TP INT] (TP INT)
        , Fun "mod"         [TP INT, TP INT] (TP INT)
        , Fun "cat"         [TP TXT, TP TXT] (TP TXT)
        , Fun "take"        [TP INT, TP TXT] (TP TXT)
        , Fun "drop"        [TP INT, TP TXT] (TP TXT)
        , Fun "lower"       [TP TXT] (TP TXT)
        , Fun "upper"       [TP TXT] (TP TXT)
        , Fun "and"         [TP BOOL, TP BOOL] (TP BOOL)
        , Fun "or"          [TP BOOL, TP BOOL] (TP BOOL)
        , Fun "imp"         [TP BOOL, TP BOOL] (TP BOOL)
        , Fun "eqv"         [TP BOOL, TP BOOL] (TP BOOL)
        , Fun "not"         [TP BOOL] (TP BOOL)
        , Fun "parseInt"    [TP TXT] (TP INT)
        , Fun "toTxtInt"    [TP INT] (TP TXT)
        , Fun "toTxtBool"   [TP BOOL] (TP TXT)
        ] 
        
    where
        
    emptyClass = TC emptyClassName
    emptyInterface = TCn [emptyClass]

emptyClassName :: U_
emptyClassName = U_"*Empty"

emptyClassDecl :: Cdecl
emptyClassDecl = Cdecl emptyClassName [] Nothing [] []
        
--
-- fix program' 
--

fixPrg' :: Program' -> ErrMsg (FunTab, Program)
fixPrg' (Program' funs cdecls mm) =
        do
            case find (\(s, s') -> s == s') [(s, s') | f@(Fun s _ _) <- allFuns, f'@(Fun s' _ _) <- allFuns, f /= f'] of
                Just (s, _) -> fail ("inconsistent function declaration: " ++ s)
                _ -> return ()
        
            cdecls' <- mape pCdecl (emptyClassDecl:cdecls)
            mm' <- pMainm mm
            return (allFuns, Program cdecls' mm') where
    
    allFuns = funs ++ builtInFuns
    
    pCdecl (Cdecl cl xspecs ext adefs mdefs) =
            do
                xspecs' <- mape (pXSpec tvs) xspecs  
                ext' <- pExt tvs ext
                adefs' <- mape (pAdef tvs) adefs
                mdefs' <- mape (pMdef tvs) mdefs
                return (Cdecl cl xspecs' ext' adefs' mdefs') where
            
        tvs = (cl, [s | XSpec (X_ _ s) _ _ <- xspecs])
        
    pMainm (Mainm tps k) =
            do
                let ztvs = (undefined, [])
                tps' <- mape (fixTyping' ztvs) tps
                k' <- fixCmd' allFuns ztvs k
                return (Mainm tps' k')
        
    pXSpec tvs (XSpec tv scnstr mcnstr) =
            do
                scnstr' <- fixTem' tvs scnstr
                mcnstr' <- fixTem' tvs mcnstr
                return (XSpec tv scnstr' mcnstr')
        
    pExt = fixTem'
    
    pAdef tvs (Adef vis tp) =
            do
                tp' <- fixTyping' tvs tp
                return (Adef vis tp')
        
    pMdef tvs (Mdef la tps k) =
            do
                tps' <- mape (fixTyping' tvs) tps
                k' <- fixCmd' allFuns tvs k
                return (Mdef la tps' k')
        
fixTyping' :: XTab -> Typing -> ErrMsg Typing
fixTyping' tvs (Typing te la) =
        do
            te' <- fixTe' tvs te
            return (Typing te' la)
        
fixCmd' :: FunTab -> XTab -> Cmd -> ErrMsg Cmd
fixCmd' funs tvs c =
        case c of 
            Decl tps -> do
                tps' <- mape (fixTyping' tvs) tps
                return (Decl tps')
            New te ep -> do
                te' <- fixTe' tvs te
                ep' <- pExp ep
                return (New te' ep')
            Assign ep1 ep2 -> do
                ep1' <- pExp ep1
                ep2' <- pExp ep2
                return (Assign ep1' ep2')
            Invk ep la vs las cas rs -> do
                ep' <- pExp ep
                vs' <- mape pExp vs
                cas' <- mape (fixTem' tvs) cas
                rs' <- mape pExp rs
                return (Invk ep' la vs' las cas' rs')
            Seq k1 k2 -> do
                k1' <- fixCmd' funs tvs k1
                k2' <- fixCmd' funs tvs k2
                return (Seq k1' k2')
            If ep k1 k2 -> do
                ep' <- pExp ep
                k1' <- fixCmd' funs tvs k1
                k2' <- fixCmd' funs tvs k2
                return (If ep' k1' k2')
            While ep k -> do
                ep' <- pExp ep
                k' <- fixCmd' funs tvs k
                return (While ep' k')
            Print eol eps -> do
                eps' <- mape pExp eps
                return (Print eol eps')
            _ -> return c

    where
    
    pExp ep = 
            case ep of
                App (Fun s _ _) eps -> do
                    fun' <- find (\(Fun s' _ _) -> s == s') funs |? "function not declared: " ++ show s
                    eps' <- mape pExp eps
                    return (App fun' eps')
                Attr ep' la -> do
                    ep'' <- pExp ep'
                    return (Attr ep'' la)
                Cast te ep' -> do
                    te' <- fixTe' tvs te
                    ep'' <- pExp ep'
                    return (Cast te' ep'')
                _ -> return ep

fixTe' :: XTab -> Te -> ErrMsg Te 
fixTe' tvs@(cl, ltvs) te = 
        case te of
            TC (U_ s) ->  
                if s `elem` ltvs then return (TX (X_ cl s)) else return te
            TCn tes -> do
                tes' <- mape (fixTe' tvs) tes
                return (TCn tes')
            TCj cl' sst -> do
                let (tvs', tes) = unzipSst sst
                tes' <- mape (fixTe' tvs) tes
                return (TCj cl' (zipSst tvs' tes'))
            _ -> return te
    
fixTem' :: XTab -> Maybe Te -> ErrMsg (Maybe Te)
fixTem' tvs tem = 
        case tem of 
            Nothing -> return Nothing
            Just te -> do
                te' <- fixTe' tvs te
                return (Just te')

fixMainCmd' :: FunTab -> Cmd -> ErrMsg Cmd
fixMainCmd' funs c =
        do
            let ztvs = (undefined, [])
            k <- fixCmd' funs ztvs c
            return k
        
--
-- end of RgAS
--
-- --$Id: RgAS.hs 1188 2012-11-13 16:27:51Z wke@IPM.EDU.MO $