{-# OPTIONS_GHC -XFlexibleContexts -XTemplateHaskell #-}
module Syntax.Context (
    
    Context(..),
    emptyContext, defaultContext,
    addToTypes, addToConstructors, addToClasses, addToMembers, addToInstances, 
    addToTypeSyns, 
    
    C, withC, runC, lookIn, getCtors, getType, getSuperClasses, getInstances,
    allInstances,
    safeCatchErrorC,

    boolCon, eitherCon, intCon, maybeCon,

    module Control.Monad.Reader
    ) where

import qualified Data.Map as Map

import Syntax.Type
import Syntax.Name
import Syntax.Expressions

import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Identity
import Data.Maybe (catMaybes)

-------------------------------------------------------------------------------
-- Defining Context
--------------------------------------------------------------------------------

-- not fully used yet
data Context = Ctx
    { ctx_types    :: !(Map.Map Name Type)
    -- mapping a function name to its type
    , ctx_ctors    :: !(Map.Map Name [Name])
    -- mapping a type name to its constructors
    , ctx_classes  :: !(Map.Map Name [Name])
    -- mapping a class name to its superclasses
    , ctx_members  :: !(Map.Map Name [Name])
    -- mapping a class name to the name of its member functions
    , ctx_instances  :: !(Map.Map Name [Type])
    -- mapping a class name to its member types
--    , ctx_instances  :: !(Map.Map Type [Name])
-- mapping a type to its classes, of which it is a member   
    , ctx_typesyns  :: !(Map.Map  Type Type)
}deriving(Show)

emptyContext = Ctx 
    { ctx_types     = Map.empty
    , ctx_ctors     = Map.empty
    , ctx_classes   = Map.empty
    , ctx_members   = Map.empty
    , ctx_instances = Map.empty
    , ctx_typesyns  = Map.empty
} 
addToTypes :: [(Name, Type)] -> Context -> Context
addToTypes l c  = foldl add c l 
    where    
    add ctx (n, ty) =
        let types = ctx_types ctx 
        in ctx{ctx_types = Map.insert n ty types}    

addToConstructors :: [(Name, [Name])] -> Context -> Context
addToConstructors l c  =  foldl add c l
    where    
    add ctx (n, ty) =
        let ctors = ctx_ctors ctx 
        in ctx{ctx_ctors = Map.insert n ty ctors}
            
addToClasses :: [(Name, [Name])] -> Context -> Context
addToClasses l c  = foldl add c l 
    where
    add ctx (n, ns) = 
        let classes = ctx_classes ctx 
        in ctx{ctx_classes = Map.insert n ns classes} 
             
addToMembers :: [(Name, [Name])] -> Context -> Context
addToMembers l c  = foldl add c l 
    where
    add ctx (n, ns) = 
        let members = ctx_members ctx 
        in ctx{ctx_members = Map.insert n ns members}       
     
addToInstances :: [(Type, Name)] -> Context -> Context
addToInstances l c  = foldl add c l 
    where
    add ctx (ty, n) = 
        let insts = ctx_instances ctx
        in ctx{ctx_instances = Map.insertWith (++) n [ty] insts}    

addToTypeSyns :: [(Type, Type)] -> Context -> Context
addToTypeSyns l c  = foldl add c l 
    where
    add ctx (syn, ty) =
        let tysyns = ctx_typesyns ctx
        in  
        ctx{ctx_typesyns = Map.insert syn ty tysyns}    
    
   
defaultContext = Ctx 
    { ctx_types     = defaulttypes
    , ctx_ctors     = defaultctors
    , ctx_classes   = defaultclasses
    , ctx_members   = defaultmembers
    , ctx_instances = defaultinstances
    , ctx_typesyns = defaulttypesyns
}

boolCon = conT ''Bool
eitherCon = conT ''Either
maybeCon = conT ''Maybe
intCon = conT ''Int

defaultbindings  = Map.empty
defaulttypes     = Map.fromList
    [('(==), arrowT [varT "a", varT "a", boolCon])
--
--    , '(/=), arrowT [varT "a", varT "a", boolCon])
    ,('(<), arrowT [varT "a", varT "a", boolCon])
--    ,('(>=), arrowT [varT "a", varT "a", boolCon])
    ,('(>), arrowT [varT "a", varT "a", boolCon])
--    ,('(<=), arrowT [varT "a", varT "a", boolCon])
    ,('(:),     arrowT [varT "a", listT (varT "a"), listT (varT "a")])
    ,('[],      listT (varT "a") )
    ,('True,    boolCon)
    ,('False,   boolCon)
    ,('undefined, varT "a")
    ,('Just,    arrowT [varT "a", appT maybeCon (varT "a")])
    ,('Nothing, appT maybeCon (varT "a") )
    ,('Left,    arrowT [varT "a", foldAppT eitherCon [varT "a", varT "b"]])
    ,('Right,   arrowT [varT "b", foldAppT eitherCon [varT "a", varT "b"]])
    ]
    
defaultctors     = Map.fromList 
    [(''[]     ,['[],'(:)])
    ,(''Bool   ,['False,'True])
    ,(''Maybe  ,['Just, 'Nothing])
    ,(''Either , ['Left,'Right])
    ]
defaultclasses   = Map.fromList
    [(''Ord,[''Eq])
    ,(''Eq,[])]
defaultmembers   = Map.fromList
    [(''Eq,['(==)
           --,'(/=)
           ])
    ,(''Ord,['(<)
--            ,'(>=)
            ,'(>)
--            ,'(<=)
            ])
    ]


defaultinstances = Map.fromList
    [(''Eq, [ boolCon
            , intCon
            , forallT [(''Eq, "a")] $ listT (varT "a")
            , forallT [(''Eq, "a")] $ appT maybeCon (varT "a")
            ])
    ,(''Ord, [ boolCon
             , intCon
             , forallT [(''Ord, "a")] $ listT (varT "a")
             , forallT [(''Ord, "a")] $ appT maybeCon (varT "a")
             ])
    ]
defaulttypesyns  = Map.empty


--------------------------------------------------------------------------------
-- a MonadTransformer with Context
--------------------------------------------------------------------------------

type C m = ReaderT Context m

withC :: Monad m => C m a -> Context -> m a
withC = runReaderT

runC :: Monad m => C m a -> m a
runC = flip withC defaultContext

lookIn :: (Ord a, Show a, MonadReader Context m) => (Context -> Map.Map a b) -> a -> m (Maybe b)
lookIn f n = asks f >>= \m -> return (Map.lookup n m)

getType :: (MonadReader Context m) => Name -> m (Maybe Type)
getType = lookIn ctx_types

getCtors :: (MonadReader Context m) => Name -> m (Maybe [Name])
getCtors = lookIn ctx_ctors
        
getSuperClasses :: (MonadReader Context m) => Name -> m [Name]        
getSuperClasses n = lookIn ctx_classes n >>= return . (maybe [] id)
        
getInstances :: (MonadReader Context m) => Name -> m [Type]        
getInstances n = lookIn ctx_instances n >>=  return . (maybe [] id)                

allInstances :: (MonadReader Context m) => m [(Name,[Type])]
allInstances = asks (Map.toList . ctx_instances)

safeCatchErrorC :: Monad m => C (Either String) a -> (String -> C m a) -> C m a
safeCatchErrorC c h = mapReaderT return c >>= either h return