module Syntax.Specification where

import qualified Data.Map as Map

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

-- import Data.Rules
import Data.Either (partitionEithers)
import Data.List (intersperse)

import Control.Monad.Error
import Control.Monad.State

import qualified Syntax.Context as SC


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


data Equation = UnGuardEq  [TExp] TExp 
              | GuardedEq  [TExp] [(TExp,TExp)]  
    deriving(Eq,Ord,Show)
               
mkEq  = UnGuardEq
mkGEq = GuardedEq
            
data FunBind  = FunB  Name [Equation]
    deriving(Eq,Ord,Show)

mkFB = FunB   
fName (FunB n _ ) = n
fEqus (FunB _ e ) = e

data Specification = Spec
    { spec_bindings :: !(Map.Map Name [Equation])
    -- mapping a function name to its clauses
    , spec_ctx   :: !SC.Context
    }deriving(Show)
    
spec_types     = SC.ctx_types . spec_ctx
spec_ctors     = SC.ctx_ctors . spec_ctx
spec_classes   = SC.ctx_classes . spec_ctx
spec_members   = SC.ctx_members . spec_ctx
spec_instances = SC.ctx_instances . spec_ctx
spec_typesyns  = SC.ctx_typesyns . spec_ctx

synCtxOnly :: Specification -> SC.Context
synCtxOnly = spec_ctx

getBindings :: [Name] -> Specification -> Either String [FunBind]
getBindings ns ctx = do
    let (ls,rs) = partitionEithers $ map (getBinding ctx) ns
    if not.null $ ls
      then Left $ errmsg ls
      else return rs
    where
    errmsg s = "No examples found for function name(s) " ++
               concat (intersperse ", " s) ++ "!"

getBinding :: (Error e, MonadError e m) => Specification -> Name -> m FunBind
getBinding ctx n =
    case Map.lookup n (spec_bindings ctx) of
        Just rs -> return $ FunB n rs
        Nothing -> throwError $ strMsg $ "'" ++ show n ++ "'"

addToBindings :: [FunBind] -> Specification -> Specification
addToBindings l c = foldl add c l 
    where
    add ctx fb = 
        let bindings = spec_bindings ctx
        in ctx{spec_bindings = Map.insert (fName fb) (fEqus fb) bindings}

addToTypes :: [(Name, Type)] -> Specification -> Specification
addToTypes l c  = 
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToTypes l sctx} 

addToConstructors :: [(Name, [Name])] -> Specification -> Specification
addToConstructors l c  =  
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToConstructors l sctx}   
            
addToClasses :: [(Name, [Name])] -> Specification -> Specification
addToClasses l c  = 
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToClasses l sctx}   
             
addToMembers :: [(Name, [Name])] -> Specification -> Specification
addToMembers l c  = 
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToMembers l sctx}       
     
addToInstances :: [(Type, Name)] -> Specification -> Specification
addToInstances l c  = 
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToInstances l sctx}   

addToTypeSyns :: [(Type, Type)] -> Specification -> Specification
addToTypeSyns l c  = 
    let sctx = spec_ctx c
    in c{spec_ctx = SC.addToTypeSyns l sctx}  
    

    
defaultSpec = Spec 
    { spec_bindings  = defaultbindings
    , spec_ctx    = SC.defaultContext
}

defaultbindings = Map.empty
            
emptySpec ctx = Spec 
    { spec_bindings  = Map.empty
    , spec_ctx    = ctx
}