{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XFlexibleContexts -XGeneralizedNewtypeDeriving 
                -XTemplateHaskell -XNoMonomorphismRestriction -XFlexibleInstances #-}
-- | Defines the abstract syntax tree for LSL (and LSL Plus extensions).
module Language.Lsl.Syntax (
    -- Types
    Expr(..),
    Var(..),
    FuncDec (..),
    Func(..),
    LModule(..),
    Component(..),
    Statement(..),
    LSLType(..),
    Handler(..),
    State(..),
    GlobDef(..),
    LSLScript(..),
    Validity,
    Global(..),
    SourceContext(..),
    Ctx(..),
    CompiledLSLScript(..),
    Library,
    AugmentedLibrary,
    CodeErr,
    CtxVar,
    CtxName,
    CtxExpr,
    CtxStmt,
    ModuleInfo,
    Codebase(..),
    -- Values
    fromMCtx,
    ctxItems,
    nullCtx,
    ctxVr2Vr,
    findFunc,
    --validLSLScript,
    --validLibrary,
    moduleFromScript,
    findState,
    predefFuncs,
    findFuncDec,
    goodHandlers,
    libFromAugLib,
    isTextLocation,
    compileLSLScript,
    compileLSLScript',
    compileLibrary,
    VState,
    emptyValidationState) where

import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString)
import Language.Lsl.Internal.Constants(isConstant,findConstType)
import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors)
import Language.Lsl.Internal.FuncSigs(funcSigs)
import Language.Lsl.Internal.AccessGenerator(genAccessorsForType,genMAccessorsForType)
import Data.Generics
import Data.Data(Data,Typeable)
import Data.List(find,sort,sortBy,nub,foldl')
import qualified Data.Map as M
import Data.Maybe(isJust,isNothing)
import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError)
import Control.Monad(when,foldM,MonadPlus(..))
import Control.Monad.Error(MonadError(..),Error(..))
import qualified Control.Monad.State as S(State)
import Control.Monad.State hiding(State)

import Debug.Trace
--trace1 s v = trace (s ++ show v) v

data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } |
                     UnknownSourceContext
                     deriving (Show,Typeable,Data)

isTextLocation (TextLocation _ _ _ _ _) = True
isTextLocation _ = False

-- | A wrapper that can associate a source code context with a value (e.g. a syntax value).
data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data)
instance Functor Ctx where
    fmap f (Ctx c v) = (Ctx c $ f v)

ctxItems = map ctxItem

fromMCtx :: Maybe (Ctx a) -> Maybe a
fromMCtx = fmap ctxItem

nullCtx :: a -> Ctx a
nullCtx = Ctx UnknownSourceContext

funcNames = map (ctxItem.funcName)

ctxVr2Vr :: (Ctx a,b) -> (a,b)
ctxVr2Vr (Ctx _ name,c) = (name,c)

type CtxVar = Ctx Var

-- | An LSL variable (a name, and a type).
data Var = Var { varName :: String, varType :: LSLType } deriving (Show,Typeable,Data)

type CtxName = Ctx String

-- | An LSL function declaration (the function name and type information, without associated
-- statements.
data FuncDec = FuncDec { funcName :: CtxName, funcType :: LSLType, funcParms :: [CtxVar] }
    deriving (Show,Typeable,Data)

type CtxStmt = Ctx Statement
-- | An LSL function definition (return type, parameters and statements.
data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data)

-- | An LSL Plus module, which is a separately 'compiled' unit that can contain
-- both global variables and functions, but not states or handlers.
data LModule = LModule [GlobDef] [CtxVar]
    deriving (Show,Typeable,Data)

type CtxExpr = Ctx Expr
-- | An LSL expression.
data Expr = IntLit Int
          | FloatLit Float
          | StringLit String
          | ListExpr [CtxExpr]
          | VecExpr CtxExpr CtxExpr CtxExpr
          | RotExpr CtxExpr CtxExpr CtxExpr CtxExpr
          | KeyLit String
          | Call CtxName [CtxExpr]
          | Add CtxExpr CtxExpr
          | Sub CtxExpr CtxExpr
          | Mul CtxExpr CtxExpr
          | Div CtxExpr CtxExpr
          | Mod CtxExpr CtxExpr
          | Get (CtxName,Component)
          | Set (CtxName,Component) CtxExpr
          | BAnd CtxExpr CtxExpr
          | BOr CtxExpr CtxExpr
          | Xor CtxExpr CtxExpr
          | ShiftL CtxExpr CtxExpr
          | ShiftR CtxExpr CtxExpr
          | And CtxExpr CtxExpr
          | Or CtxExpr CtxExpr
          | Equal CtxExpr CtxExpr
          | NotEqual CtxExpr CtxExpr
          | Lt CtxExpr CtxExpr
          | Le CtxExpr CtxExpr
          | Gt CtxExpr CtxExpr
          | Ge CtxExpr CtxExpr
          | IncBy (CtxName,Component) CtxExpr
          | DecBy (CtxName,Component) CtxExpr
          | MulBy (CtxName,Component) CtxExpr
          | DivBy (CtxName,Component) CtxExpr
          | ModBy (CtxName,Component) CtxExpr
          | PostInc (CtxName,Component)
          | PostDec (CtxName,Component)
          | PreInc (CtxName,Component)
          | PreDec (CtxName,Component)
          | Not CtxExpr
          | Neg CtxExpr
          | Inv CtxExpr
          | Cast LSLType CtxExpr
          | AQString String
          | AQInteger String
          | AQKey String
          | AQFloat String
            deriving (Show,Typeable,Data)

-- | An LSL statement.
data Statement = Compound [CtxStmt]
               | While CtxExpr Statement
               | DoWhile Statement CtxExpr
               | For ([CtxExpr]) (Maybe CtxExpr) ([CtxExpr]) Statement
               | If CtxExpr Statement Statement
               | Decl Var (Maybe CtxExpr)
               | NullStmt
               | Return (Maybe CtxExpr)
               | StateChange String
               | Do CtxExpr
               | Label String
               | Jump String
    deriving (Show,Typeable,Data)

isLabel (Label _) = True
isLabel _ = False

-- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals
-- for a script is derived after analyzing all included modules.
data Global = GDecl Var (Maybe Expr)
    deriving (Show,Typeable,Data)

-- | A global definition (a function, a variable, or a module import statement).
data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String
    deriving (Show,Typeable,Data)
-- | An LSL event handler definition.
data Handler = Handler CtxName [CtxVar] [CtxStmt]
    deriving (Show,Typeable,Data)
    
-- | The set of valid handlers supported by LSL.
goodHandlers :: [(String,[LSLType])]
goodHandlers = simpleLslEventDescriptors

-- | An LSL state definition.
data State = State CtxName [Handler]
    deriving (Show,Typeable,Data)

-- | An LSL script.
data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data)

type ModuleInfo = ([Global],[Func])
-- | A collection of modules.
type Library = [(String,Validity LModule)]
-- | A collection of mouldes, augmented with additional derived information.
type AugmentedLibrary = [(String,Validity (LModule,ModuleInfo))]

data Codebase = Codebase { codebaseLib :: AugmentedLibrary, codebaseScripts :: [(String,Validity CompiledLSLScript)] }

lslFunc (name,t,ts) =
    FuncDec (nullCtx name) t (zipWith (\ x y -> nullCtx $ Var [y] x) ts ['a'..])
predefFuncs = map lslFunc funcSigs

findVar name = find (\(Var n _ ) -> n == name)
findType name =
    let f Nothing = Nothing
        f (Just (Var _ t )) = Just t in f . (findVar name)
findFuncDec name = ctx ("finding function " ++ name) . findM (\ fd -> ctxItem (funcName fd) == name)
findState name = ctx ("finding state " ++ name) . findM (\ (State n _) -> ctxItem n == name)
findFunc name = ctx ("finding function " ++ name) . findM (\ (Func fd _) -> ctxItem (funcName fd) == name)

lookupModule :: String -> Library -> Validity LModule
lookupModule name lib =
    case lookup name lib of
        Nothing -> throwError [(UnknownSourceContext, "unknown module")]
        Just (Left ((_,s):_)) -> throwError [(UnknownSourceContext, "invalid library (" ++ s ++ ")")]
        Just (Right m) -> return m

-- A description of an error and where to find it in the source.
type CodeErr = (SourceContext,String)

ctxFromCodeErr = fst
msgFromCodeErr = snd

-- | An error monad for representing validation errors with respect to LSL code.
type Validity a = Either [CodeErr] a

instance Error [CodeErr] where
    noMsg = [(UnknownSourceContext,"")]
    strMsg s = [(UnknownSourceContext,s)]
    
incontext (ctx,s) (Left ((ctx',s'):_)) =
    case ctx' of
        UnknownSourceContext -> Left [(ctx,msg)]
        _ -> Left [(ctx',msg)]
    where msg = if null s then s' else s ++ ": " ++ s'
incontext _ v = v

incontext' (ctx,s) (Left ((_,s'):_)) = Left [(ctx,s ++ ": " ++ s')]
incontext' _ v = v

--------------------
matchTypes LLFloat LLInteger = True
matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src])

typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs)
typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = 
    return (vars,(FuncDec (fmap (prefix++) name) t params):funcs)
typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') =
    do (LModule globs _) <- lookupModule (ctxItem moduleName) library
       foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs
typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs

noDupVars :: [String] -> [CtxVar] -> Validity [String]
noDupVars used [] = return used
noDupVars used ((Ctx ctx (Var n t)):vs) = do
    when (n `elem` used) $ throwError [(ctx, n ++ " already defined")]
    noDupVars (n:used) vs

checkName :: Maybe SourceContext -> String -> [String] -> Validity ()
checkName (Just ctx) name names = 
    when (name `elem` names) $ throwError [(ctx, name ++ " is multiply defined")]

data CompiledLSLScript = CompiledLSLScript {
    scriptGlobals :: ![Global],
    scriptFuncs :: ![Func],
    scriptStates :: ![State]}
    deriving (Show)

data RefPos = RefPos { refPosName :: !String, refPosLine :: !Int, refPosCol :: !Int }
    deriving (Show,Eq,Ord)
    
data ValidationState = ValidationState {
        vsLib :: !Library,
        vsGlobalRegistry :: !(M.Map String SourceContext),
        vsLocalRegistry :: ![M.Map String SourceContext],
        vsLocalVars :: ![[Var]],
        vsRefs :: !(M.Map RefPos SourceContext),
        vsLabels :: ![[String]],
        vsModules :: ![String],
        vsGlobDefs :: ![GlobDef],
        vsStates :: ![State],
        vsGlobals :: ![Global],
        vsFuncs :: ![Func],
        vsErr :: ![CodeErr],
        vsWarn :: ![CodeErr],
        vsNamesUsed :: [String],
        vsGVs :: ![Var],
        vsGFs :: ![FuncDec],
        vsStateNames :: ![String],
        vsEntryPointInfo :: !(LSLType,Bool),
        vsBranchReturns :: !Bool,
        vsHandlersUsed :: ![String],
        vsImports :: ![(String,[(String,String)],String)],
        vsContext :: [SourceContext]
    }
    
emptyValidationState = ValidationState {
    vsLib = [], 
    vsGlobalRegistry = M.empty,
    vsLocalRegistry = [], 
    vsLocalVars = [], 
    vsRefs = M.empty, 
    vsLabels = [],
    vsModules = [], 
    vsGlobDefs = [], 
    vsStates = [], 
    vsGlobals = [], 
    vsFuncs = [],
    vsErr = [], 
    vsWarn = [], 
    vsNamesUsed = [], 
    vsGVs = [], 
    vsGFs = [], 
    vsStateNames = [], 
    vsEntryPointInfo = (LLVoid,False), 
    vsBranchReturns = False, 
    vsHandlersUsed = [], 
    vsImports = [], 
    vsContext = [] 
    }
-- generate set'xxx methods for all the record selectors in the above type...
-- warning: all types mentioned in the above declaration must be defined (lexically) prior to
-- the following splice
-- double warning: the 'set' functions generated can only be used in code that
-- lexically follows this splice   
$(genAccessorsForType ''ValidationState) -- a Template Haskell splice...
-- this splice requires the above splice, and, because the author of the splice was too lazy to
-- generate type signatures, also requires -XNoMonomorphismRestriction
$(genMAccessorsForType ''ValidationState) -- a Template Haskell splice...

type VState a = S.State ValidationState a

--vsmRegisterGlobal :: Ctx Var -> VState ()
vsmRegisterGlobalName name ctx = get'vsGlobalRegistry >>= put'vsGlobalRegistry . (M.insert name ctx)
vsmRegisterGlobal (Ctx ctx (Var name t)) = vsmRegisterGlobalName name ctx
vsmRegisterFunc (Func (FuncDec (Ctx ctx name) _ _) _) = vsmRegisterGlobalName name ctx

vsmRegisterLocalName name ctx = do
    lregistry <- get'vsLocalRegistry
    case lregistry of
        [] -> error "no local scope on stack"
        (top:rest) -> put'vsLocalRegistry (M.insert name ctx top : rest)

vsmAddGlobalRef name ctx = do
    registry <- get'vsGlobalRegistry
    case M.lookup name registry of
        Nothing -> return ()
        Just UnknownSourceContext -> return ()
        Just ctx -> do
            refs <- get'vsRefs
            put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs)

vsmAddRef name ctx = do
      lr <- get'vsLocalRegistry
      go lr
   where go [] = vsmAddGlobalRef name ctx
         go (top:rest) = do
             case M.lookup name top of
                 Nothing -> go rest
                 Just UnknownSourceContext -> return ()
                 Just ctx -> do
                     refs <- get'vsRefs
                     put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs)
                   
vsmAddGV :: Var -> VState ()
vsmAddGV var = get'vsGVs >>= put'vsGVs . (var:)
vsmAddGF :: FuncDec -> VState ()
vsmAddGF fd = get'vsGFs >>= put'vsGFs . (fd:)

vsmAddFunc :: Func -> VState ()
vsmAddFunc func = get'vsFuncs >>= put'vsFuncs . (func :)

vsmAddGlobal :: Global -> VState ()
vsmAddGlobal global = get'vsGlobals >>= put'vsGlobals . (global :)

vsmAddState :: State -> VState ()
vsmAddState state = get'vsStates >>= put'vsStates . (state :)

vsmAddLocal :: SourceContext -> Var -> VState ()
vsmAddLocal ctx v@(Var name _) = do
    locals <- get'vsLocalVars
    case locals of
        [] -> error "internal error - no local scope"
        (top:rest) -> 
            if (defined name $ concat locals) || (isConstant name)
                then vsmAddErr (ctx, name ++ " is already defined")
                else do
                    put'vsLocalVars ((v:top):rest)
                    vsmRegisterLocalName name ctx
            
vsmAddImport imp = get'vsImports >>= put'vsImports . (imp:)

vsmAddToNamesUsed :: String -> VState ()
vsmAddToNamesUsed name = get'vsNamesUsed >>= put'vsNamesUsed . (name :)

vsmWithNewScope :: VState a -> VState a
vsmWithNewScope action = do
    get'vsLocalRegistry >>= put'vsLocalRegistry . (M.empty:)
    get'vsLabels >>= put'vsLabels . ([]:)
    get'vsLocalVars >>= put'vsLocalVars . ([]:)
    val <- action
    get'vsLocalRegistry >>= (\ (_:reg) -> put'vsLocalRegistry reg)
    get'vsLabels >>= (\ (_:labels) -> put'vsLabels labels)
    get'vsLocalVars >>= (\ (_:vars) -> put'vsLocalVars vars)
    return val

vsmWithModule :: String -> VState () -> VState ()
vsmWithModule mname action = get'vsModules >>= put'vsModules . (mname:) >> action >> get'vsModules >>= (\ (_:ms) -> put'vsModules ms)

vsmAddErr :: CodeErr -> VState ()
vsmAddErr err = do
    ctx <- get'vsContext >>= return . safeHead
    errs <- get'vsErr
    put'vsErr ((maybe (ctxFromCodeErr err) id ctx, msgFromCodeErr err) : errs)

vsmAddErrs :: [CodeErr] -> VState ()
vsmAddErrs = mapM_ vsmAddErr

vsmAddLabel :: String -> VState ()
vsmAddLabel label = do
    labels <- get'vsLabels
    case labels of
        [] -> error "no local scope!"
        (top:rest) -> put'vsLabels ((label:top):rest)

vsmAddHandler handlerName = get'vsHandlersUsed >>= put'vsHandlersUsed . (handlerName:)
        
vsmWithContext :: SourceContext -> VState a -> VState a
vsmWithContext srcCtx action = do
    ctxs <- get'vsContext
    put'vsContext (srcCtx:ctxs)
    v <- action
    put'vsContext ctxs
    return v
    
vsmInEntryPoint :: LSLType -> Bool -> VState a -> VState a
vsmInEntryPoint t stateChangeAllow action = do
    put'vsEntryPointInfo (t,stateChangeAllow)
    action
    
vsmInBranch :: VState a -> VState a
vsmInBranch action = do
    info <- get'vsBranchReturns
    put'vsBranchReturns False
    val <- action
    put'vsBranchReturns info
    return val
    
vsmWithinState action = do
    put'vsHandlersUsed []
    action

whenM mp action = do
    p <- mp
    when p action
    
whenJust mv action =
    case mv of
        Nothing -> return ()
        Just v -> action v

whenIsJust mv p action =
    case mv of
        Nothing -> return ()
        Just v | p v -> action
               | otherwise -> return ()
               
safeHead [] = Nothing
safeHead (x:_) = Just x
    
vsmFirstErr :: VState (Maybe CodeErr)
vsmFirstErr = get'vsErr >>= \ l -> case l of
     l@(_:_) -> return $ Just $ last l -- list is reversed...
     _       -> return Nothing

compileLSLScript' :: Library ->LSLScript -> Validity CompiledLSLScript
compileLSLScript' library script = evalState (compileLSLScript script) (emptyValidationState { vsLib = library })

compileLSLScript :: LSLScript -> VState (Validity CompiledLSLScript)
compileLSLScript (LSLScript globs states) = do
    preprocessGlobDefs_ "" globs
    preprocessStates states
    mapM_ vsmAddGF predefFuncs
    mapM_ compileGlob globs
    mapM_ compileState states
    err <- get'vsErr -- vsmFirstErr
    case err of
        [] -> do
           globals <- get'vsGlobals
           funcs <- get'vsFuncs
           states <- get'vsStates
           return $ Right $ CompiledLSLScript (reverse globals) (reverse funcs) (reverse states)
        _ -> return $ Left $ reverse err

preprocessStates states = let snames = map (\ (State cn _) -> ctxItem cn) states in put'vsStateNames snames

preprocessGlobDefs :: String -> [GlobDef] -> VState ([Var],[FuncDec])
preprocessGlobDefs prefix globs = do
    preprocessGlobDefs_ prefix globs
    vars <- get'vsGVs
    funcDecs <- get'vsGFs
    return (vars,funcDecs)
    
preprocessGlobDefs_ :: String -> [GlobDef] -> VState ()
preprocessGlobDefs_ = mapM_ . preprocessGlobDef
    
preprocessGlobDef :: String -> GlobDef -> VState ()
preprocessGlobDef prefix (GV (Ctx ctx v@(Var name t)) _) = vsmAddGV (Var (prefix ++ name) t)
preprocessGlobDef prefix (GF (Func (FuncDec name t params) _)) = vsmAddGF (FuncDec (fmap (prefix++) name) t params)
preprocessGlobDef prefix (GI moduleName _ prefix') = do
    lib <- get'vsLib
    case lookupModule (ctxItem moduleName) lib of
        Left err -> vsmAddErrs err
        Right (LModule globs _) -> mapM_ (preprocessGlobDef (prefix++prefix')) globs
        
compileGlob :: GlobDef -> VState ()
compileGlob (GV v mexpr) = do
    let v' = ctxItem v
    when (isConstant $ varName v') (vsmAddErr (srcCtx v, varName v' ++ " is a predefined constant"))
    namesUsed <- get'vsNamesUsed
    gvs <- get'vsGVs
    when (varName v' `elem` namesUsed) (vsmAddErr (srcCtx v, varName v' ++ " is already defined"))
    whenJust mexpr $ \ expr -> do
       let (_,gvs') = break (\ var -> varName var == varName v') gvs
       mt <- compileCtxSimple (drop 1 gvs') expr
       whenJust mt $ \ t -> when (not (varType v' `matchTypes` t)) (vsmAddErr (srcCtx v, "expression not of the correct type"))
    vsmRegisterGlobal v
    vsmAddToNamesUsed (varName v')
    vsmAddGlobal (GDecl v' (fmap ctxItem mexpr))
compileGlob (GF f@(Func (FuncDec name t params) statements)) =
    vsmWithNewScope $ do
        compileParams params
        vsmInEntryPoint t False $ do
            whenM ((return elem) `ap` (return $ ctxItem name) `ap` get'vsNamesUsed) (vsmAddErr (srcCtx name, ctxItem name ++ " is already defined"))
            returns <- compileStatements statements
            when (not returns && t /= LLVoid) (vsmAddErr (srcCtx name, ctxItem name ++ ": not all code paths return a value"))
            vsmRegisterFunc f
            vsmAddToNamesUsed $ ctxItem name
            vsmAddFunc f
compileGlob (GI (Ctx ctx name) bindings prefix) =
    vsmWithModule name $ do
        let imp = (name, sort bindings, prefix)
        imports <- get'vsImports
        when (not (imp `elem` imports)) $ do
            library <- get'vsLib
            case lookupModule name library of
                Left errs -> vsmAddErrs (map (\ (_,err) -> (ctx, "module " ++ name ++ ": " ++ err)) errs)
                Right (LModule globs freevars) -> do
                   vars <- get'vsGVs
                   case validBindings vars freevars bindings of
                       Left err -> vsmAddErr (ctx, err)
                       Right () -> do
                           let (vars',funcDecs') = evalState (preprocessGlobDefs "" globs) (emptyValidationState { vsLib = library })
                           let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs')))
                           vsmAddImport imp
                           vsmWithContext ctx $ mapM_ (rewriteGlob' prefix renames (map ctxItem freevars ++ vars')) globs

rewriteGlob' prefix renames vars (GF (Func (FuncDec name t params) statements)) =
    case lookup (ctxItem name) renames of
        Nothing -> vsmAddErr (srcCtx name, "can't rename " ++ ctxItem name ++ ": not found")
        Just name' -> do
            namesUsed <- get'vsNamesUsed
            if name' `elem` namesUsed 
                then  vsmAddErr (srcCtx name, name' ++ " imported from module is already defined")
                else let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements)
                     in do  vsmAddToNamesUsed name'
                            vsmRegisterFunc rewrittenFunc
                            vsmAddFunc rewrittenFunc
rewriteGlob' prefix renames vars (GV (Ctx ctx (Var name t)) mexpr) =
    case lookup name renames of
        Nothing -> vsmAddErr (ctx, "can't rename " ++ name ++ ": not found")
        Just name' -> do
            namesUsed <- get'vsNamesUsed
            if name' `elem` namesUsed
                then vsmAddErr (ctx, name' ++ " imported from module is already defined")
                else let rewrittenGlobVar = GDecl (Var name' t) (fmap (ctxItem . (rewriteCtxExpr renames)) mexpr)
                     in do vsmAddToNamesUsed name'
                           vsmRegisterGlobal (Ctx ctx (Var name' t))
                           vsmAddGlobal rewrittenGlobVar
rewriteGlob' prefix0 renames vars (GI (Ctx ctx mName) bindings prefix) = 
    do lib <- get'vsLib
       case lookupModule mName lib of
           Left errs -> vsmAddErrs (map (\ (_,err) -> (ctx, err)) errs)
           Right (LModule globs freevars) -> do
               case validBindings vars freevars bindings of
                  Left err -> vsmAddErr (ctx, err)
                  Right _ -> do
                      bindings' <- mapM rewriteBinding bindings
                      let imp = (mName,sort bindings', prefix0 ++ prefix)
                      imports <- get'vsImports
                      when (not (imp `elem` imports)) $ do
                          let (vars',funcDecs') = evalState (preprocessGlobDefs "" globs) (emptyValidationState { vsLib = lib })
                          let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs')
                          vsmAddImport imp
                          mapM_ (rewriteGlob' (prefix0 ++ prefix) renames vars') globs
    where rewriteBinding (fv,rn) = case lookup rn renames of
                                       Nothing -> vsmAddErr (ctx, rn ++ ": not found") >> return (fv,rn)
                                       Just rn' -> return (fv,rn')

compileState :: State -> VState ()
compileState state@(State nm handlers) = 
    vsmWithinState $ do
        states <- get'vsStates
        when (isJust (find (\ (State x _)-> ctxItem x == ctxItem nm) states)) $
            vsmAddErr (srcCtx nm, ctxItem nm ++ " already defined") 
        mapM_ compileHandler handlers
        vsmAddState state

compileHandler  (Handler (Ctx ctx name) args stmts) =
    vsmWithNewScope $ do
        used <- get'vsHandlersUsed
        if name `elem` used then vsmAddErr (ctx, name ++ " already used in this state")
                            else vsmAddHandler name
        case lookup name goodHandlers of
            Nothing -> vsmAddErr (ctx, name ++ " is not a valid handler name")
            Just types -> when (types /= map varType (ctxItems args)) $ vsmAddErr (ctx, "invalid parameter types for handler " ++ name)
        compileParams args
        vsmInEntryPoint LLVoid True $ compileStatements stmts

compileCtxSimple :: [Var] -> CtxExpr -> VState (Maybe LSLType)
compileCtxSimple gvs (Ctx ctx expr) = do
    t <- compileSimple gvs expr
    case t of
        Nothing -> vsmAddErr (ctx,"expression is not valid as an initializer for a global variable") >> return t
        _ -> return t

compileSimple :: [Var] -> Expr -> VState (Maybe LSLType)
compileSimple _ (IntLit i) = return $ Just LLInteger
compileSimple _ (FloatLit i) = return $ Just LLFloat
compileSimple _ (StringLit s) = return $ Just LLString
compileSimple _ (KeyLit k) = return $ Just LLKey
compileSimple gvs (Get (Ctx ctx name, All)) = do
    vsmAddGlobalRef name ctx
    let var = find (\ v -> varName v == name) gvs
    case var of
        Just (Var _ t) -> return $ Just t
        Nothing -> case findConstType name of
            Nothing -> vsmAddErr (ctx,"variable " ++ name ++ " not found") >> return Nothing
            Just t -> return $ Just t
compileSimple _ (Get (Ctx ctx name,_)) = do
    vsmAddGlobalRef name ctx
    vsmAddErr (ctx, "can't access vector/rotation component in global variable initialization") >> return Nothing
compileSimple _ (ListExpr []) = return $ Just LLList
compileSimple vars (ListExpr (e:es)) = do
    mt <- compileCtxSimple vars e
    case mt of
        Nothing -> return Nothing
        Just t -> do
            when (t == LLList) (vsmAddErr (srcCtx e, "lists cannot contain other lists"))
            compileSimple vars (ListExpr es)
compileSimple vars (VecExpr e1 e2 e3) = compileSimpleStructure vars LLVector [e1,e2,e3]
compileSimple vars (RotExpr e1 e2 e3 e4) = compileSimpleStructure vars LLRot [e1,e2,e3,e4]
compileSimple vars (Neg e) = do
    mt <- compileCtxSimple vars e
    case mt of
        Nothing -> return Nothing
        Just t -> 
            if (t `notElem` [LLFloat,LLInteger]) 
                then vsmAddErr (srcCtx e, "operator only applicable to integers and floats in this context") >> return Nothing
                else return (Just t)
compileSimple _ e = return Nothing

compileSimpleStructure :: [Var] -> LSLType -> [CtxExpr] -> VState (Maybe LSLType)
compileSimpleStructure _ t [] = return (Just t)
compileSimpleStructure vars t (e:es) = do
    mt <- compileCtxSimple vars e
    case mt of
        Nothing -> return Nothing
        Just t' ->
            if (t' `notElem` [LLFloat,LLInteger])
                then vsmAddErr (srcCtx e, "literal of type " ++ lslTypeString t' ++  " is not a valid element of " ++ lslTypeString t) 
                     >> return Nothing
                else compileSimpleStructure vars t es

compileStatement :: Ctx Statement -> VState Bool
compileStatement  (Ctx ctx (Decl var@(Var name t) expr)) = do
    vsmAddLocal ctx var
    case expr of
       Nothing -> return ()
       Just expr' -> do mt' <- compileCtxExpr expr'
                        case mt' of
                            Nothing -> return ()
                            Just t' -> when (not $ matchTypes t t') $ vsmAddErr (srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t)
    get'vsBranchReturns
compileStatement  (Ctx ctx (While expr statement)) = do
    t <- compileCtxExpr expr
    vsmInBranch $ compileStatement (nullCtx statement)
    get'vsBranchReturns
compileStatement (Ctx ctx(DoWhile statement expr)) =
    do t <- compileCtxExpr expr
       vsmInBranch $ compileStatement (nullCtx statement)
       get'vsBranchReturns
compileStatement (Ctx ctx (For mexpr1 mexpr2 mexpr3 statement)) =
    do  compileExpressions mexpr1
        compileExpressions mexpr3
        t <- compileMExpression mexpr2
        vsmInBranch $ compileStatement (nullCtx statement)
        get'vsBranchReturns
compileStatement (Ctx ctx (If expr thenStmt elseStmt)) =
    do t <- compileCtxExpr expr
       ret1 <- vsmInBranch $ compileStatement (nullCtx thenStmt)
       ret2 <- vsmInBranch $ compileStatement (nullCtx elseStmt)
       returns <- get'vsBranchReturns
       put'vsBranchReturns (returns || (ret1 && ret2))
       get'vsBranchReturns
compileStatement (Ctx ctx NullStmt) = get'vsBranchReturns
compileStatement (Ctx ctx (Return Nothing)) = 
    do  (rtype,_) <- get'vsEntryPointInfo
        when (rtype /= LLVoid) (vsmAddErr (ctx,"function must return a value"))
        put'vsBranchReturns True
        return True
compileStatement (Ctx ctx (Return (Just expr))) = 
    do  t <- compileCtxExpr expr
        case t of
            Nothing -> return ()
            Just t' -> do
                (rtype,_) <- get'vsEntryPointInfo
                when (t' /= rtype && not (all (`elem` [LLString,LLKey]) [t',rtype])) (vsmAddErr (ctx,"inappropriate return type for function/handler"))
        put'vsBranchReturns True
        return True
compileStatement (Ctx ctx (StateChange name)) = do
    (_,scallow) <- get'vsEntryPointInfo
    snames <- get'vsStateNames
    when (not scallow) $ vsmAddErr (ctx,"state changes not allowed from this context")
    when (not (name `elem` snames)) $ vsmAddErr (ctx,name ++ " is not a valid state")
    get'vsBranchReturns
compileStatement (Ctx ctx (Do expr)) = compileCtxExpr expr >> get'vsBranchReturns
compileStatement (Ctx ctx (Compound stmts)) = compileStatements stmts
compileStatement (Ctx ctx (Label _)) = put'vsBranchReturns False >> return False
compileStatement (Ctx ctx (Jump s)) = 
    do labels <- get'vsLabels
       when (s `notElem` concat labels) $ vsmAddErr (ctx, "no such label to jump to: " ++ s)
       get'vsBranchReturns


compileStatements :: [CtxStmt] -> VState Bool
compileStatements stmts =
    do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts)
       vsmWithNewScope $ do
           mapM_ vsmAddLabel newLabels
           mapM_ compileStatement stmts
           get'vsBranchReturns

compileParams :: [CtxVar] -> VState ()
compileParams vs = mapM_ ( \(Ctx ctx v) -> vsmAddLocal ctx v) vs

isCastValid t t' = (t' == t) || (t,t') `elem` validCasts
   where validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger),
                      (LLInteger,LLString),(LLString,LLInteger),
                      (LLFloat,LLString),(LLString,LLFloat),
                      (LLString,LLVector),(LLVector,LLString),
                      (LLString,LLKey),(LLKey,LLString),
                      (LLRot,LLString),(LLString,LLRot),
                      (LLList,LLString),(LLString,LLList)]

compileCtxExpr :: Ctx Expr -> VState (Maybe LSLType)
compileCtxExpr (Ctx ctx (Cast t expr)) = 
   do mt <- compileCtxExpr expr
      case mt of
          Nothing -> return ()
          Just t' -> when (not $ isCastValid t' t) $ vsmAddErr (ctx,"cannot cast a value of type " ++ lslTypeString t' ++ " to type " ++ lslTypeString t)
      return (Just t)
compileCtxExpr (Ctx ctx0 (Get ((Ctx ctx name),component))) = do
   vsmAddRef name ctx
   vars <- get'vsGVs
   locals <- get'vsLocalVars
   let varList = (concat locals ++ vars)
   case (findType name varList `mplus` findConstType name,component) of
       (Nothing,_) -> vsmAddErr (ctx, "undefined variable or constant: " ++ name) >> return Nothing
       (Just LLRot,All) -> return $ Just LLRot
       (Just LLRot,_) -> return $ Just LLFloat
       (Just LLVector,All) -> return $ Just LLVector
       (Just LLVector,S) -> vsmAddErr (ctx0,"s is not a valid component of a vector") >> (return $ Just LLFloat)
       (Just LLVector,_) -> return $ Just LLFloat
       (Just t,All) -> return $ Just t
       (Just t,_) -> vsmAddErr (ctx,"only vectors and rotations have components") >> return Nothing
compileCtxExpr (Ctx ctx (Call name exprs)) = compileCall name exprs
compileCtxExpr (Ctx ctx (Not expr)) =
    do mt <- compileCtxExpr expr
       (mt `whenIsJust` (/=LLInteger)) $ vsmAddErr (ctx, "operator not applicable to non-integer type")
       return $ Just LLInteger
compileCtxExpr (Ctx ctx (Neg expr))  =
    do mt <- compileCtxExpr expr
       (mt `whenIsJust` (==LLList)) $ vsmAddErr (ctx, "operator not applicable to list type")
       return mt
compileCtxExpr (Ctx ctx (Inv expr)) =
    do mt <- compileCtxExpr expr
       (mt `whenIsJust` (/=LLInteger)) $ vsmAddErr (srcCtx expr, "operator not applicable to non-integer type")
       return mt
compileCtxExpr (Ctx ctx plus@(Add expr1 expr2)) =
    do  (mt1,mt2) <- compileEach (expr1,expr2)
        case (mt1,mt2) of
            (Nothing,Just t2) -> return (Just t2)
            (Just t1,Nothing) -> return (Just t1)
            (Nothing,Nothing) -> return Nothing
            (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
            (Just LLInteger,Just LLFloat) -> return $ Just LLFloat
            (Just LLFloat,Just LLInteger) -> return $ Just LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just LLFloat
            (Just LLVector,Just LLVector) -> return $ Just LLVector
            (Just LLRot,Just LLRot) -> return $ Just LLRot
            (Just LLString,Just LLString) -> return $ Just LLString
            (Just LLList,Just LLList) -> return $ Just LLList
            (Just t,Just LLList) -> return $ Just LLList
            (Just LLList,Just t) -> return $ Just LLList
            (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing
compileCtxExpr (Ctx ctx minus@(Sub expr1 expr2)) =
    do  (mt1,mt2) <- compileEach (expr1,expr2)
        case (mt1,mt2) of
            (Nothing,Just t2) -> return (Just t2)
            (Just t1,Nothing) -> return (Just t1)
            (Nothing,Nothing) -> return Nothing
            (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
            (Just LLInteger,Just LLFloat) -> return $ Just LLFloat
            (Just LLFloat,Just LLInteger) -> return $ Just LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just LLFloat
            (Just LLVector,Just LLVector) -> return $ Just LLVector
            (Just LLRot,Just LLRot) -> return $ Just LLRot
            (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing
compileCtxExpr (Ctx ctx expr@(Mul expr1 expr2)) =
    do  (mt1,mt2) <- compileEach (expr1,expr2)
        case (mt1,mt2) of
            (Nothing,Just t2) -> return (Just t2)
            (Just t1,Nothing) -> return (Just t1)
            (Nothing,Nothing) -> return Nothing
            (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
            (Just LLInteger,Just LLFloat) -> return $ Just LLFloat
            (Just LLFloat,Just LLInteger) -> return $ Just LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just LLFloat
            (Just LLVector,Just LLInteger) -> return $ Just LLVector
            (Just LLVector,Just LLFloat) -> return $ Just LLVector
            (Just LLFloat,Just LLVector) -> return $ Just LLVector
            (Just LLInteger,Just LLVector) -> return $ Just LLVector
            (Just LLVector,Just LLVector) -> return $ Just LLFloat
            (Just LLVector,Just LLRot) -> return $ Just LLVector
            (Just LLRot,Just LLRot) -> return $ Just LLRot
            (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing
compileCtxExpr (Ctx ctx expr@(Div expr1 expr2)) =
    do  (mt1,mt2) <- compileEach (expr1,expr2)
        case (mt1,mt2) of
            (Nothing,Just t2) -> return (Just t2)
            (Just t1,Nothing) -> return (Just t1)
            (Nothing,Nothing) -> return Nothing
            (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
            (Just LLInteger,Just LLFloat) -> return $ Just LLFloat
            (Just LLFloat,Just LLInteger) -> return $ Just LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just LLFloat
            (Just LLVector,Just LLInteger) -> return $ Just LLVector
            (Just LLVector,Just LLFloat) -> return $ Just LLVector
            (Just LLVector,Just LLRot) -> return $ Just LLVector
            (Just LLRot,Just LLRot) -> return $ Just LLRot
            (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing
compileCtxExpr (Ctx ctx expr@(Mod expr1 expr2)) =
    do (mt1,mt2) <- compileEach (expr1,expr2)
       case (mt1,mt2) of
           (Nothing,Just t2) -> return (Just t2)
           (Just t1,Nothing) -> return (Just t1)
           (Nothing,Nothing) -> return Nothing
           (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
           (Just LLVector,Just LLVector) -> return $ Just LLVector
           (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(Equal expr1 expr2)) =
    do (mt1,mt2) <- compileEach (expr1,expr2)
       case (mt1,mt2) of
           (Nothing,Just t2) -> return (Just t2)
           (Just t1,Nothing) -> return (Just t1)
           (Nothing,Nothing) -> return Nothing
           (Just LLInteger,Just LLFloat) -> return $ Just LLInteger
           (Just LLFloat,Just LLInteger) -> return $ Just LLInteger
           (Just LLString,Just LLKey) -> return $ Just LLInteger
           (Just LLKey,Just LLString) -> return $ Just LLInteger
           (Just t1,Just t2) | (t1 == t2) -> return $ Just LLInteger
                             | otherwise  -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(NotEqual expr1 expr2)) =
    do (mt1,mt2) <- compileEach (expr1,expr2)
       case (mt1,mt2) of
           (Nothing,Just t2) -> return (Just t2)
           (Just t1,Nothing) -> return (Just t1)
           (Nothing,Nothing) -> return Nothing
           (Just LLInteger,Just LLFloat) -> return $ Just LLInteger
           (Just LLFloat,Just LLInteger) -> return $ Just LLInteger
           (Just LLString,Just LLKey) -> return $ Just LLInteger
           (Just LLKey,Just LLString) -> return $ Just LLInteger
           (Just t1,Just t2) | (t1 == t2) -> return $ Just LLInteger
                             | otherwise  -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(BAnd expr1 expr2)) = compileBothInteger ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(BOr expr1 expr2)) = compileBothInteger ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(Xor expr1 expr2)) = compileBothInteger ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(ShiftL expr1 expr2)) = compileBothInteger ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(ShiftR expr1 expr2)) = compileBothInteger ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(Gt expr1 expr2)) = compileRelExpr ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(Ge expr1 expr2)) = compileRelExpr ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(Le expr1 expr2)) = compileRelExpr ctx (expr1,expr2)
compileCtxExpr (Ctx ctx e@(Lt expr1 expr2)) = compileRelExpr ctx (expr1, expr2)
compileCtxExpr (Ctx ctx e@(And expr1 expr2)) = compileBothInteger ctx (expr1, expr2)
compileCtxExpr (Ctx ctx e@(Or expr1 expr2)) = compileBothInteger ctx (expr1, expr2)
compileCtxExpr (Ctx ctx e@(IncBy (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLInteger,Just LLInteger) -> return $ Just  LLInteger
            (Just LLFloat,Just LLInteger) -> return $ Just  LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just  LLFloat
            (Just LLVector,Just LLVector) -> return $ Just  LLVector
            (Just LLRot,Just LLRot) -> return $ Just  LLRot
            (Just LLString,Just LLString) -> return $ Just  LLString
            (Just LLList,Just LLList) -> return $ Just  LLList
            (Just LLList,Just t) -> return $ Just  LLList
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(IncBy (name,_) expr) ) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just  LLFloat
                          | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(DecBy (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLInteger,Just LLInteger) -> return $ Just  LLInteger
            (Just LLFloat,Just LLInteger) -> return $ Just  LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just  LLFloat
            (Just LLVector,Just LLVector) -> return $ Just  LLVector
            (Just LLRot,Just LLRot) -> return $ Just  LLRot
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(DecBy (name,_) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just  LLFloat
                              | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(MulBy (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLInteger,Just LLInteger) -> return $ Just  LLInteger
            (Just LLFloat,Just LLInteger) -> return $ Just  LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just  LLFloat
            (Just LLVector,Just LLInteger) -> return $ Just  LLVector
            (Just LLVector,Just LLFloat) -> return $ Just  LLVector
            (Just LLVector,Just LLVector) -> return $ Just  LLVector -- note: LSL compiles this, but it results in runtime error!
            (Just LLVector,Just LLRot) -> return $ Just  LLVector
            (Just LLRot,Just LLRot) -> return $ Just  LLRot
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(MulBy (name,_) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just  LLFloat
                              | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(DivBy (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLInteger,Just LLInteger) -> return $ Just  LLInteger
            (Just LLFloat,Just LLInteger) -> return $ Just  LLFloat
            (Just LLFloat,Just LLFloat) -> return $ Just  LLFloat
            (Just LLVector,Just LLInteger) -> return $ Just  LLVector
            (Just LLVector,Just LLFloat) -> return $ Just  LLVector
            (Just LLVector,Just LLRot) -> return $ Just  LLVector
            (Just LLRot,Just LLRot) -> return $ Just  LLRot
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(DivBy (name,_) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just  LLFloat
                              | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(ModBy (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLInteger,Just LLInteger) -> return $ Just  LLInteger
            (Just LLVector,Just LLVector) -> return $ Just  LLVector
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(ModBy (name,_) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx e@(PostInc var)) = compileIncDecOp var "++"
compileCtxExpr (Ctx ctx e@(PostDec var)) = compileIncDecOp var "--"
compileCtxExpr (Ctx ctx e@(PreInc var)) = compileIncDecOp var "++"
compileCtxExpr (Ctx ctx e@(PreDec var)) = compileIncDecOp var "++"
compileCtxExpr (Ctx ctx expr0@(Set (name,All) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLFloat,Just LLInteger) -> return $ Just  LLFloat
            (Just LLKey,Just LLString) -> return $ Just  LLKey
            (Just LLString,Just LLKey) -> return $ Just  LLString
            (Just t1,Just t2) | t1 == t2 -> return $ Just  t1
                    | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx expr0@(Set (name,S) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLRot,Just LLFloat) -> return $ Just  LLFloat
            (Just LLRot,Just LLInteger) -> return $ Just  LLFloat
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx expr0@(Set (name,_) expr)) =
    do  reportErrorIfNoModify name
        (mt1,mt2) <- compileNameExpr (name,expr)
        case (mt1,mt2) of
            (Nothing,Nothing) -> return Nothing
            (Just t1,Nothing) -> return $ Just t1
            (Nothing,Just t2) -> return $ Just t2
            (Just LLVector,Just LLFloat) -> return $ Just  LLFloat
            (Just LLVector,Just LLInteger) -> return $ Just  LLFloat
            (Just LLRot,Just LLFloat) -> return $ Just  LLFloat
            (Just LLRot,Just LLInteger) -> return $ Just  LLFloat
            (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing
compileCtxExpr (Ctx ctx (IntLit i)) = return $ Just  LLInteger
compileCtxExpr (Ctx ctx (FloatLit _)) = return $ Just  LLFloat
compileCtxExpr (Ctx ctx (StringLit _)) = return $ Just  LLString
compileCtxExpr (Ctx ctx (KeyLit _)) = return $ Just  LLKey
compileCtxExpr (Ctx ctx (ListExpr es)) = do
    mapM compileListExprElement es
    return $ Just  LLList
compileCtxExpr (Ctx ctx (VecExpr xExpr yExpr zExpr)) = 
    do  xt <- compileCtxExpr xExpr
        yt <- compileCtxExpr yExpr
        zt <- compileCtxExpr zExpr
        when (not (all (`elem` [LLInteger,LLFloat]) [c | Just c <- [xt,yt,zt]])) $ vsmAddErr (ctx, "invalid components for vector")
        return $ Just  LLVector
compileCtxExpr (Ctx ctx (RotExpr xExpr yExpr zExpr sExpr)) = 
    do  xt <- compileCtxExpr xExpr
        yt <- compileCtxExpr yExpr
        zt <- compileCtxExpr zExpr
        st <- compileCtxExpr sExpr
        when (not (all (`elem` [LLInteger,LLFloat]) [ c | Just c <- [xt,yt,zt,st]])) $ vsmAddErr (ctx, "invalid components for rotation")
        return $ Just LLRot

reportErrorIfNoModify (Ctx ctx name) = 
    when (isConstant name) $ vsmAddErr (ctx, "cannot modify " ++ name ++ " because it is a constant")
    
reportIncompatibleOperands ctx t0 t1 = 
    vsmAddErr (ctx,"the types of the operands aren't compatible (" ++ lslTypeString t0 ++ " vs. " ++ lslTypeString t1 ++ ")")
    
compileExpressions es = mapM_ compileCtxExpr es
compileMExpression Nothing = return (Just LLVoid)
compileMExpression (Just expr) = compileCtxExpr expr

compileCall (Ctx ctx fname) exprs = do
    vsmAddRef fname ctx
    funcs <- get'vsGFs
    case findFuncDec fname funcs of
        Nothing -> vsmAddErr (ctx,fname ++ ": no such function in scope") >> return Nothing
        Just (FuncDec _ t params) ->
            let vArg :: Int -> [Var] -> [Ctx Expr] -> VState ()
                vArg _ [] [] = return ()
                vArg _ (p:ps) [] = vsmAddErr (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)
                vArg _ [] (a:as) = vsmAddErr (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)
                vArg n (Var name t:ts) (arg:args) = 
                  do mt' <- compileCtxExpr arg
                     case mt' of
                         Nothing -> return ()
                         Just t' -> when (not (matchTypes t t')) $ vsmAddErr (ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t))
                     vArg (n+1) ts args
            in vArg 1 (ctxItems params) exprs >> return (Just t)
            
compileEach :: (Ctx Expr,Ctx Expr) -> VState (Maybe LSLType, Maybe LSLType)
compileEach (expr1,expr2) = do
    mt1 <- compileCtxExpr expr1
    mt2 <- compileCtxExpr expr2
    return (mt1,mt2)
compileBothInteger ctx (expr1,expr2) = do
    (mt1,mt2) <- compileEach (expr1,expr2)
    case (mt1,mt2) of
        (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
        (Just _, Just _) -> vsmAddErr (ctx,"operands are of incompatible type") >> return Nothing
        _ -> return Nothing
compileRelExpr ctx (expr1,expr2) = do
    do (mt1,mt2) <- compileEach (expr1,expr2)
       case (mt1,mt2) of
           (Nothing,_) -> return Nothing
           (_,Nothing) -> return Nothing
           (Just LLInteger,Just LLInteger) -> return $ Just LLInteger
           (Just LLInteger,Just LLFloat) -> return $ Just LLInteger
           (Just LLFloat,Just LLInteger) -> return $ Just LLInteger
           (Just LLFloat,Just LLFloat) -> return $ Just LLInteger
           (Just t0,Just t1) -> vsmAddErr (ctx,"operands are of incompatible types") >> return Nothing
compileNameExpr (Ctx ctx name,expr) = do
    vsmAddRef name ctx
    locals <- get'vsLocalVars
    globvars <- get'vsGVs
    mt <- compileCtxExpr expr
    let mvt = findType name (concat locals ++ globvars)
    when (isNothing mvt) $ vsmAddErr (ctx,"variable " ++ name ++ " not defined")
    return (mvt,mt)

compileIncDecOp (n@(Ctx ctx name),c) op = do
    vsmAddRef name ctx
    reportErrorIfNoModify n
    locals <- get'vsLocalVars
    vars <- get'vsGVs
    case (findType name (concat locals ++ vars),c) of
        (Nothing,_) ->  vsmAddErr (ctx, "variable " ++ name ++ " not found") >> return Nothing
        (Just LLInteger,All) -> return $ Just LLInteger
        (Just LLFloat,All) -> return $ Just LLFloat
        (Just LLRot,S) -> return $ Just LLFloat
        (Just LLVector,S) -> vsmAddErr (ctx, "s is not a valid component of " ++ name) >> return Nothing
        (Just t,All) -> vsmAddErr (ctx, name ++ " is not a valid operand for " ++ op) >> return Nothing
        (Just LLVector,_) -> return $ Just LLFloat
        (Just LLRot,_) -> return $ Just LLFloat
        _ -> vsmAddErr (ctx, name ++ " is not a valid operand for " ++ op) >> return Nothing

compileListExprElement e@(Ctx ctx _) = do
    mt <- compileCtxExpr e
    case mt of
        Nothing -> return ()
        Just t | t `elem` [LLVoid,LLList] -> vsmAddErr (ctx,"invalid list element")
               | otherwise -> return ()

validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript
validLSLScript library (LSLScript globs states) = 
    do  (typedVars,typedFuncs) <- typeGlobs library globs
        let vars = reverse typedVars
        let funcDecs = typedFuncs ++ predefFuncs
        (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs
        validStates snames [] vars funcDecs states
        return (CompiledLSLScript (reverse globvars) funcs states)
    where snames = let sname (State cn _) = ctxItem cn in map sname states
validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) =
    do when (isConstant $ varName v') $ throwError [(srcCtx v, varName v' ++ " is a predefined constant")]
       -- find the vars that are defined prior to this global variable -- only one of these
       -- vars may be used to initialize the global variable.
       when (varName v' `elem` namesUsed) $ throwError [(srcCtx v, varName v' ++ " is already defined")]
       let (vars',_) = break (\ var -> varName var == varName v') vars
       case mexpr of
           Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed)
           Just expr -> do
               t <- validCtxSimple vars' expr
               let vt = varType v'
               when (not (matchTypes vt t)) $ throwError [(srcCtx expr, "expression not of the correct type")]
               return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed)
    where v' = ctxItem v
validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) =
    do  noDupVars [] params
        when (ctxItem name `elem` namesUsed) $ throwError [(srcCtx name, ctxItem name ++ " is already defined")]
        returns <- validStatements False [] funcDecs vars t [] [[],params'] statements
        when (not returns && t /= LLVoid) $
            throwError [(srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value")]
        return (globvars,f:funcs,imports,(ctxItem name):namesUsed)
    where params' = ctxItems params
validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) =
    let context = incontext' (ctx,"module " ++ name) in
    do  let imp = (name,sort bindings,prefix)
        if imp `elem` imports 
            then return (globvars,funcs,imports,namesUsed) 
            else context $ do
                (LModule globs freevars) <- context $ lookupModule name library
                context $ validBindings vars freevars bindings
                (vars',funcDecs') <- context $ typeGlobs library globs
                let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs')))
                (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs
                return (gvs,fs,imp:imports',namesUsed')

rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) =
    do  name' <- incontext (srcCtx name,  "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames
        when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined")
        let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements)
        return (globvars,rewrittenFunc:funcs,imports,name':namesUsed)
rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) =
    do  name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames
        when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined")
        let rewrittenGlobVar = GDecl (Var name' t) $
                case mexpr of
                    Nothing -> Nothing
                    Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr))
        return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed)
rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) =
    do  (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library
        incontext (ctx,"") $ validBindings vars freevars bindings
        bindings' <- mapM rewriteBinding bindings
        let imp = (mName,sort bindings',prefix0 ++ prefix)
        if (imp `elem` imports)
            then return (globvars,funcs,imports,namesUsed)
            else do
                (vars',funcDecs') <- typeGlobs library globs
                let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs')
                (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs
                return (gvs,fs,imp:imports',namesUsed')
    where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv)

validBindings vars freevars bindings = 
    if length freevars /= length bindings then
        throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required")
    else let f [] = return ()
             f ((x,y):xys) = 
                case (findType x (ctxItems freevars), findType y vars) of
                    (Nothing,_) -> throwStrError ("free variable " ++ x ++ " not found")
                    (_,Nothing) -> throwStrError ("global variable " ++ y ++ " not found")
                    (Just t0,Just t1) | not (matchTypes t0 t1) -> throwStrError ("types of " ++ x ++ " and " ++ y ++ " don't match")
                            | otherwise -> f xys
         in f bindings

validState snames used vars funcs (State (Ctx ctx name) handlers) =
    do when (name `elem` used) $ throwError [(ctx, name ++ " already used")]
       incontext (ctx,"") $ validHandlers snames [] funcs vars handlers
       return name
       
validStates snames used vars funcs [] = return ()
validStates snames used vars funcs (s:ss) =
    do  name <- validState snames used vars funcs s
        validStates snames (name:used) vars funcs ss
        
validCast t0 t1 =
    let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger),
                      (LLInteger,LLString),(LLString,LLInteger),
                      (LLFloat,LLString),(LLString,LLFloat),
                      (LLString,LLVector),(LLVector,LLString),
                      (LLString,LLKey),(LLKey,LLString),
                      (LLRot,LLString),(LLString,LLRot),
                      (LLList,LLString),(LLString,LLList)] in
    do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1))

validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType
validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr
       
validSimple :: [Var] -> Expr -> Validity LSLType
validSimple vars (IntLit i) = return LLInteger
validSimple vars (FloatLit f) = return LLFloat
validSimple vars (StringLit s) = return LLString
validSimple vars (KeyLit k) = return LLKey
validSimple vars (Get (Ctx ctx name,All)) = 
    (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars
        return t)
    `mplus` (findConstType name)
validSimple vars (Get (Ctx ctx name,_)) = throwError [(ctx,"can't access vector/rotation component in global variable initialization")]
validSimple vars (ListExpr []) = return LLList
validSimple vars (ListExpr (e:es)) = 
    do t <- validCtxSimple vars e
       when (t == LLList) $ throwError [(srcCtx e,"lists cannot contain other lists")]
       validSimple vars (ListExpr es)
validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3]
validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4]
validSimple vars (Neg e) = 
    do t <- validCtxSimple vars e
       when (t `notElem` [LLFloat, LLInteger]) $ throwError [(srcCtx e,"operator only applicable to integers and floats in this context")]
       return t
validSimple vars e = throwStrError ("expression is not valid in a static context.")

validSimpleStructure vars t [] = return t
validSimpleStructure vars t (e:es) =
    do  t' <- validCtxSimple vars e
        when (t' `notElem` [LLFloat,LLInteger]) $ throwError [(srcCtx e, "literal of type " ++
             (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t))]
        validSimpleStructure vars t es

validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType
validExpression (Cast t expr) funcs vars locals  = 
   do t' <- validCtxExpr expr funcs vars locals
      incontext (srcCtx expr, "") $ validCast t' t
      return t
validExpression (Get ((Ctx ctx name),component)) funcs vars locals =
   case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of
       (Nothing,_) -> throwError [(ctx, "undefined variable or constant: " ++ name)]
       (Just LLRot,All) -> return LLRot
       (Just LLRot,_) -> return LLFloat
       (Just LLVector,All) -> return LLVector
       (Just LLVector,S) -> throwError [(ctx,"s is not a valid component of a vector")]
       (Just LLVector,_) -> return LLFloat
       (Just t,All) -> return t
       (Just t,_) -> throwError [(ctx,"only vectors and rotations have components")]
validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs
validExpression (Not expr) funcs vars locals =
    do t <- validCtxExpr expr funcs vars locals
       when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator")]
       return t
validExpression (Neg expr) funcs vars locals =
    do t <- validCtxExpr expr funcs vars locals
       when (t == LLList) $ throwError [(srcCtx expr, "operator not applicable to list type")]
       return t
validExpression (Inv expr) funcs vars locals =
    do t <- validCtxExpr expr funcs vars locals
       when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator")]
       return t
validExpression plus@(Add expr1 expr2) funcs vars locals =
    do  (t1,t2) <- validEach (expr1,expr2) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLInteger,LLFloat) -> return LLFloat
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLVector) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (LLString,LLString) -> return LLString
            (LLList,LLList) -> return LLList
            (t,LLList) -> return LLList
            (LLList,t) -> return LLList
            (t0,t1) -> incompatibleOperands plus t0 t1
validExpression minus@(Sub expr1 expr2) funcs vars locals =
    do  (t1,t2) <- validEach (expr1,expr2) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLInteger,LLFloat) -> return LLFloat
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLVector) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands minus t0 t1
validExpression expr@(Mul expr1 expr2) funcs vars locals=
    do  (t1,t2) <- validEach (expr1,expr2) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLInteger,LLFloat) -> return LLFloat
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLInteger) -> return LLVector
            (LLVector,LLFloat) -> return LLVector
            (LLFloat,LLVector) -> return LLVector
            (LLInteger,LLVector) -> return LLVector
            (LLVector,LLVector) -> return LLFloat
            (LLVector,LLRot) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands expr t0 t1
validExpression expr@(Div expr1 expr2) funcs vars locals =
    do  (t1,t2) <- validEach (expr1,expr2) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLInteger,LLFloat) -> return LLFloat
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLInteger) -> return LLVector
            (LLVector,LLFloat) -> return LLVector
            (LLVector,LLRot) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands expr t0 t1
validExpression expr@(Mod expr1 expr2) funcs vars locals =
    do  (t1,t2) <- validEach (expr1,expr2) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLVector,LLVector) -> return LLVector
            _ -> incompatibleOperands expr t1 t2
validExpression e@(Equal expr1 expr2) funcs vars locals =
    do (t1,t2) <- validEach (expr1,expr2) funcs vars locals
       case (t1,t2) of
           (LLInteger,LLFloat) -> return LLInteger
           (LLFloat,LLInteger) -> return LLInteger
           (LLString,LLKey) -> return LLInteger
           (LLKey,LLString) -> return LLInteger
           (t1,t2) | (t1 == t2) -> return LLInteger
                   | otherwise  -> incompatibleOperands e t1 t2
validExpression e@(NotEqual expr1 expr2) funcs vars locals =
    do (t1,t2) <- validEach (expr1,expr2) funcs vars locals
       case (t1,t2) of
           (LLInteger,LLFloat) -> return LLInteger
           (LLFloat,LLInteger) -> return LLInteger
           (LLString,LLKey) -> return LLInteger
           (LLKey,LLString) -> return LLInteger
           (t1,t2) | (t1 == t2) -> return LLInteger
                   | otherwise  -> incompatibleOperands e t1 t2
validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals
validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals
validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals
validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals
validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals
validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals
validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals
validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals
validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals
validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals
validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals
validExpression e@(IncBy (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLVector) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (LLString,LLString) -> return LLString
            (LLList,LLList) -> return LLList
            (LLList,t) -> return LLList
            (t0,t1) -> incompatibleOperands e t0 t1
validExpression e@(IncBy (name,_) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat
                          | otherwise -> incompatibleOperands e t1 t2
validExpression e@(DecBy (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLVector) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands e t0 t1
validExpression e@(DecBy (name,_) expr) funcs vars locals =
    do  failIfNoModify name 
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat
                    | otherwise                                                   -> incompatibleOperands e t1 t2
validExpression e@(MulBy (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLInteger) -> return LLVector
            (LLVector,LLFloat) -> return LLVector
            (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error!
            (LLVector,LLRot) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands e t0 t1
validExpression e@(MulBy (name,_) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat
                    | otherwise -> incompatibleOperands e t1 t2
validExpression e@(DivBy (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLFloat,LLInteger) -> return LLFloat
            (LLFloat,LLFloat) -> return LLFloat
            (LLVector,LLInteger) -> return LLVector
            (LLVector,LLFloat) -> return LLVector
            (LLVector,LLRot) -> return LLVector
            (LLRot,LLRot) -> return LLRot
            (t0,t1) -> incompatibleOperands e t0 t1
validExpression e@(DivBy (name,_) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat
                    | otherwise                                                   -> incompatibleOperands e t1 t2
validExpression e@(ModBy (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLInteger,LLInteger) -> return LLInteger
            (LLVector,LLVector) -> return LLVector
            (t0,t1) -> incompatibleOperands e t0 t1
validExpression e@(ModBy (name,_) expr) funcs vars locals =
    do  failIfNoModify name 
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (t1,t2) -> incompatibleOperands e t1 t2
validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++"
validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--"
validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++"
validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++"
validExpression expr0@(Set (name,All) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLFloat,LLInteger) -> return LLFloat
            (LLKey,LLString) -> return LLKey
            (LLString,LLKey) -> return LLString
            (t1,t2) | t1 == t2 -> return t1
                    | otherwise -> incompatibleOperands expr0 t1 t2
validExpression expr0@(Set (name,S) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLRot,LLFloat) -> return LLFloat
            (LLRot,LLInteger) -> return LLFloat
            (t0,t1) -> incompatibleOperands expr0 t0 t1
validExpression expr0@(Set (name,_) expr) funcs vars locals =
    do  failIfNoModify name
        (t1,t2) <- validNameExpr (name,expr) funcs vars locals
        case (t1,t2) of
            (LLVector,LLFloat) -> return LLFloat
            (LLVector,LLInteger) -> return LLFloat
            (LLRot,LLFloat) -> return LLFloat
            (LLRot,LLInteger) -> return LLFloat
            (t0,t1) -> incompatibleOperands expr0 t0 t1
validExpression (IntLit i) _ _ _ = return LLInteger
validExpression (FloatLit _) _ _ _ = return LLFloat
validExpression (StringLit _) _ _ _ = return LLString
validExpression (KeyLit _) _ _ _ = return LLKey
validExpression (ListExpr es) fs vs ls = do
    mapM (\ e -> validListExprElement e fs vs ls) es
    return LLList
validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = 
    do  xt <- validCtxExpr xExpr funcs vars locals
        yt <- validCtxExpr yExpr funcs vars locals
        zt <- validCtxExpr zExpr funcs vars locals
        when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector"
        return LLVector
validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = 
    do  xt <- validCtxExpr xExpr funcs vars locals
        yt <- validCtxExpr yExpr funcs vars locals
        zt <- validCtxExpr zExpr funcs vars locals
        st <- validCtxExpr sExpr funcs vars locals
        when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation"
        return LLRot
--validExpression x funcs vars locals = error ("what to do with " ++ (show x))

validListExprElement (Ctx ctx e) funcs vars locals = do
    t <- validExpression e funcs vars locals
    when (t `elem` [LLVoid,LLList]) $ throwError [(ctx,"invalid type for list element")]
    return ()

validMExpression Nothing funcs vars locals = return LLVoid
validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals

validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es

validRelExpr (expr1,expr2) funcs vars locals =
    do (t1,t2) <- validEach (expr1,expr2) funcs vars locals
       case (t1,t2) of
           (LLInteger,LLInteger) -> return LLInteger
           (LLInteger,LLFloat) -> return LLInteger
           (LLFloat, LLInteger) -> return LLInteger
           (LLFloat, LLFloat) -> return LLInteger
           (t0,t1) -> throwStrError ("operands are of incompatible types")
validBothInteger (expr1, expr2) funcs vars locals =
    do (t1,t2) <- validEach (expr1,expr2) funcs vars locals
       when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") 
       return LLInteger
validEach (expr1, expr2) funcs vars locals =
    do t1 <- validCtxExpr expr1 funcs vars locals
       t2 <- validCtxExpr expr2 funcs vars locals
       return (t1,t2)

validNameExpr (Ctx ctx name, expr) funcs vars locals = 
    case (findType name (concat locals ++ vars), 
          validCtxExpr expr funcs vars locals) of
        (Just t1, Right t2) -> return (t1,t2)
        (Nothing, _) -> throwError [(ctx, "variable " ++ name ++ " not defined")]
        (_,Left s) -> throwError s
validCall funcs vars locals (Ctx ctx fname) exprs =
    do  (FuncDec _ t params) <- findFuncDec fname funcs
        let vArg _ [] [] = return ()
            vArg _ (p:ps) [] = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)]
            vArg _ [] (a:as) = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)]
            vArg n (Var name t:ts) (arg:args) = 
              do t' <- validCtxExpr arg funcs vars locals
                 when (not (matchTypes t t')) $ throwError [(ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t))]
                 vArg (n+1) ts args
        vArg 1 (ctxItems params) exprs
        return t

validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls

validIncDecOp (n@(Ctx ctx name),c) vars locals op =
    do  failIfNoModify n
        case (findType name (concat locals ++ vars),c) of
            (Nothing,_) ->  throwError [(ctx, "variable " ++ name ++ " not found")]
            (Just LLInteger,All) -> return LLInteger
            (Just LLFloat,All) -> return LLFloat
            (Just LLRot,S) -> return LLFloat
            (Just LLVector,S) -> throwError [(ctx, "s is not a valid component of " ++ name)]
            (Just t,All) -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)]
            (Just LLVector,_) -> return LLFloat
            (Just LLRot,_) -> return LLFloat
            _ -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)]

failIfNoModify (Ctx ctx name) = 
    when (isConstant name) $ throwError [(ctx,"cannot modify " ++ name ++ " because it is a constant")]

incompatibleOperands expr t0 t1 = 
    throwStrError ("types of the operands aren't compatible (" ++ 
             (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")")

defined :: String -> [Var] -> Bool
defined n = any (\ (Var n' _) -> n == n')

validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = 
    do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope
       when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant")
       case expr of
           Nothing -> return ((var:scope):scopes,returns)
           Just expr' -> do t' <- validCtxExpr expr' funcs vars locals
                            when (not $ matchTypes t t') $ throwError [(srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t)]
                            return ((var:scope):scopes,returns)
validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) =
    do t <- validCtxExpr expr funcs vars locals
       --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")]
       validStatement scallow snames funcs vars rtype labels locals False statement
       return (locals,returns)
validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) =
    do t <- validCtxExpr expr funcs vars locals
       --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")]
       validStatement scallow snames funcs vars rtype labels locals False statement
       return (locals,returns)
validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) =
    do  validExpressions mexpr1 funcs vars locals
        validExpressions mexpr3 funcs vars locals
        t <- validMExpression mexpr2 funcs vars locals
        --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition")
        validStatement scallow snames funcs vars rtype labels locals False statement
        return (locals,returns)
validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) =
    do t <- validCtxExpr expr funcs vars locals
       --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid 'if' condition")]
       (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt
       (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt
       return (locals,returns || ret1 && ret2)
validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns)
validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = 
    do  when (rtype /= LLVoid) (throwStrError "function must return a value")
        return (locals,True)
validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = 
    do  t <- validCtxExpr expr funcs vars locals
        when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler")
        return (locals,True)
validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do
    when (not scallow) $ throwStrError "state changes not allowed from this context"
    when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state")
    return (locals,returns)
validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns)
validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = 
    do  returns' <- validStatements  scallow snames funcs vars rtype labels ([]:locals) stmts
        return (locals,returns || returns')
validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False)
validStatement _ _ funcs vars rtype labels locals returns (Jump s) = 
    do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s)
       return (locals,returns)

validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = 
  incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt

validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool
validStatements scallow snames funcs vars rtype labels locals stmts =
    do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts)
       (_,r') <- foldM (\ (l,r) (n, s) -> 
           validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts
       return r'

validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = 
    do  when (name `elem` used) $ throwError [(ctx,name ++ " already used in state")]
        types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers
        when (types /= map varType args') $ throwError [(ctx,"invalid argument types for handler " ++ name)]
        when (length args /= (length $ nub $ map varName args')) $ throwError [(ctx,"not all argument names are unique for handler " ++ name)]
        validStatements True snames funcs vars LLVoid [] [[],args'] stmts
        return name
    where args' = ctxItems args
        
validHandlers _ _ _ _ [] = return ()
validHandlers snames used funcs vars (h:hs) =
    do  name <- validHandler snames used funcs vars h
        validHandlers snames (name:used) funcs vars hs

-- Validating a library of modules

compileModule :: LModule -> VState (Validity ([Global],[Func]))
compileModule m@(LModule globs freevars) = do
    mapM_ (vsmAddGV . ctxItem) freevars
    preprocessGlobDefs_ "" globs
    mapM_ vsmAddGF predefFuncs
    mapM_ compileGlob globs
    errs <- get'vsErr
    case errs of
        [] -> do
            globals <- get'vsGlobals
            funcs <- get'vsFuncs
            return $ Right $ (globals,funcs)
        _ -> return $ Left errs
-- 
validModule library m@(LModule globs freevars) = 
    do --used <- noDupGlobs Nothing "" [] library globs
       (typedVars, typedFuncs) <- typeGlobs library globs
       let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs)
       noDupVars used freevars
       let vars = freevars' ++ reverse typedVars
       let funcDecs = typedFuncs ++ predefFuncs
       (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs
       return (vs,fs)
    where freevars' = ctxItems freevars

-- this function isn't partiuclarly efficient!
moduleDependencies lib chain m =
    let f (GI s _ _) = Just (ctxItem s)
        f _          = Nothing
    in  do  (LModule globs _) <- lookupM m lib
            case filtMap f globs of
                [] -> return []
                list -> if any (`elem` list) (m:chain) then throwStrError "circular dependency"
                        else
                            do deps <- fmap concat (
                                   let chain' = (m:chain) in
                                       mapM (moduleDependencies lib chain') list)
                               return $ nub (list ++ deps)
                                
-- sort modules by dependency: for each module in the list, after sorting that module
-- will depend only on modules preceding it in the list.  This of course implies that
-- there can be no circular dependencies in the modules.
sortModules :: [(String,(LModule,[String]))] -> [(String,LModule)]
sortModules modules =
    let cmp (name,(_,deplist)) (name',(_,deplist')) = compare (length deplist, name) (length deplist', name')
        sort1 [] = []
        sort1 list =
           let sorted = sortBy cmp list
               (nodeps,deps) = span ((==0).length.snd.snd) sorted 
               exclude = map fst nodeps 
               newlist = if length nodeps == 0 then error "circular depencencies in library"
                         else map (\ (nm,(m,l)) -> (nm, (m,filter (`notElem` exclude) l))) deps
           in nodeps ++ sort1 newlist 
   in map (\ (s,(m,_)) -> (s,m)) $ sort1 modules
       
compileLibrary :: [(String,LModule)] -> [(String,Validity (LModule,ModuleInfo))]
compileLibrary modules =
    let checkDep (n,m) = case moduleDependencies modules [] n of
            Right deps -> (n,Right (m,deps))
            Left s -> (n,Left s)
        categorize (good,bad) (n,Left s) = (good,(n,s):bad)
        categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad)
        (good,bad) = foldl categorize ([],[]) $ map checkDep modules
        sorted = sortModules good
        validate augLib (name,m) =
            case evalState (compileModule m) (emptyValidationState { vsLib = libFromAugLib augLib })  of
                Left s -> (name, Left s):augLib
                Right gs -> (name,Right (m,gs)):augLib
    in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad)

validLibrary modules =
    let checkDep (n,m) = case moduleDependencies modules [] n of
            Right deps -> (n,Right (m,deps))
            Left s -> (n,Left s)
        categorize (good,bad) (n,Left s) = (good,(n,s):bad)
        categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad)
        (good,bad) = foldl categorize ([],[]) $ map checkDep modules
        sorted = sortModules good
        validate augLib (name,m) =
            case validModule (libFromAugLib augLib) m of
                Left s -> (name, Left s):augLib
                Right gs -> (name,Right (m,gs)):augLib
    in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad)

libFromAugLib :: AugmentedLibrary -> Library
libFromAugLib augLib = 
   let f (name,Left s) = (name,Left s)
       f (name,Right (lm,_)) = (name, Right lm)
   in map f augLib
   
tstLib = [
    ("alpha", LModule [GI (nullCtx "beta") [] []] []),
    ("beta", LModule  [GI (nullCtx "gamma") [] []] []),
    ("gamma", LModule [GI (nullCtx "alpha") [] []] []),
    ("omega", LModule [GI (nullCtx "lambda") [] []] []),
    ("lambda", LModule [GI (nullCtx "kappa") [] [], GI (nullCtx "sigma") [] []] []),
    ("kappa", LModule [] []),
    ("sigma", LModule [] [])]

-- | Transform a script into a module, generating function names for each handler, using the 
-- pattern <state-name>_state_<handler-name>.
-- The script following script:
--  
--  default {
--      state_entry() {
--          llSay(0,"Hello Avatar");
--      }
--  }
-- 
--  would be transformed into a module equivalent to:
-- 
--  $module
--  
--  default_state_state_entry() {
--      llSay(0,"Hello Avatar");
--  }
moduleFromScript :: CompiledLSLScript -> LModule
moduleFromScript script = LModule globDefs []
    where globDefs = globDefsFromGlobs (scriptGlobals script) ++
                     globDefsFromFuncs (scriptFuncs script) ++
                     funcDefsFromStates (scriptStates script)
          globDefsFromGlobs = map globDefFromGlob
          globDefsFromFuncs = map GF
          funcDefsFromStates = concatMap funcDefsFromState
          
globDefFromGlob (GDecl v me) = GV (nullCtx v) (fmap nullCtx me)
funcDefsFromState (State ctxnm handlers) = map (funcDefFromHandler (ctxItem ctxnm)) handlers
funcDefFromHandler stateName (Handler ctxnm params stmts) = GF $ Func (FuncDec combinedName LLVoid params) stmts
    where combinedName = nullCtx $ stateName ++ "$$" ++ (ctxItem ctxnm)

rewriteCtxExpr :: [(String,String)] -> Ctx Expr -> Ctx Expr
rewriteCtxExpr renames = everywhere (mkT (rewriteName renames))

rewriteName :: [(String,String)] -> Ctx String -> Ctx String
rewriteName renames (Ctx ctx name) =
    case lookup name renames of
        Nothing -> Ctx ctx name
        Just name' -> Ctx ctx name'
rewriteStatements _ _ [] = []
rewriteStatements n bindings (Ctx c s:ss) =
    let (n',bindings',s') = rewriteStatement n bindings s in
       (Ctx c s'):(rewriteStatements n' bindings' ss)

rewriteStatement n bindings (Compound stmts) = (n, bindings, Compound $ rewriteStatements n bindings stmts)
rewriteStatement n bindings (While expr stmt) = 
    let (_,_,stmt') = rewriteStatement n bindings stmt in
    (n, bindings, While (rewriteCtxExpr bindings expr) stmt')
rewriteStatement n bindings (DoWhile stmt expr) =
    let (_,_,stmt') = rewriteStatement n bindings stmt in
    (n, bindings, DoWhile stmt' (rewriteCtxExpr bindings expr))
rewriteStatement n bindings (For mexpr1 mexpr2 mexpr3 stmt) =
    let (_,_,stmt') = rewriteStatement n bindings stmt
        rewriteMExpr = rewriteMExpression bindings 
        rewriteEs = rewriteCtxExprs bindings in
    (n, bindings, For (rewriteEs mexpr1) (rewriteMExpr mexpr2) (rewriteEs mexpr3) stmt')
rewriteStatement n bindings (If expr stmt1 stmt2) = 
    let (_,_,stmt1') = rewriteStatement n bindings stmt1
        (_,_,stmt2') = rewriteStatement n bindings stmt2 in
        (n, bindings, If (rewriteCtxExpr bindings expr) stmt1' stmt2')
rewriteStatement n bindings (Decl (Var name t) val) =
   let (n',bindings', newname) =
           if any (\(name',_) -> name == name') bindings then let newname = "local" ++ (show n) in (n + 1, (name,newname):bindings, newname)
           else (n,bindings,name)
   in (n',bindings',Decl (Var newname t) (rewriteMExpression bindings val))
rewriteStatement n bindings (Return Nothing) = (n, bindings, Return Nothing)
rewriteStatement n bindings (Return (Just expr)) = (n, bindings, Return $ Just $ rewriteCtxExpr bindings expr)
rewriteStatement n bindings (Do expr) = (n, bindings, Do $ rewriteCtxExpr bindings expr)
rewriteStatement n bindings s = (n, bindings, s)

rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs

rewriteMExpression bindings = fmap (rewriteCtxExpr bindings)