-----------------------------------------------------------------------------
-- |
-- Module      :  Ctx
-- Copyright   :  Copyright (c) 2007 Igor Boehm - Bytelabs.org. All rights reserved.
-- License     :  BSD-style (see the file LICENSE)
-- Author      :  Igor Boehm  <igor@bytelabs.org>
--
-- This module represents a Context. It is stuffed with Elements and helps
-- to discover things like duplicate or missing definitions and bindings.
-----------------------------------------------------------------------------

module Csa.Ctx (
  -- * Types
  Ctx,
  -- * Functions
  new,empty,
  insert,member,(!),merge,
) where

{- unqualified imports  -}
import Csa.Elem (Elem, ElemClass(..))

{- qualified imports  -}
import qualified Data.Map as M

-----------------------------------------------------------------------------

{- | A context holds mappings from String's to Elem's. It is used
     to discover duplicate bindings, missing definitions, etc. -}
data Ctx = Ctx (M.Map String Elem)

instance Show Ctx where
  show (Ctx m) = "Context: \n"++
    concatMap
      (\key -> let el = m M.! key in
          " ("++ show (elemType el) ++ ": " ++ elemShow el ++ ")")
      (M.keys m)

{- | Constructor for creating a singleton Context -}
new :: Elem -> Ctx
new el = Ctx (M.singleton (elemId el) el)

{- | Constructor for creating an empty Context -}
empty :: Ctx
empty = Ctx M.empty

{- | Adds Elem to a Context. If Elem already exists it will be overwritten. -}
insert :: Ctx -> Elem -> Ctx
insert (Ctx m) el = Ctx (M.insert (elemId el) el m)

{- | Checks whether Elem already exists in a Context -}
member :: Ctx -> Elem -> Bool
member (Ctx m) el = M.member (elemId el) m

{- | Lookup the Elem in the Context -}
(!) :: Ctx -> Elem -> Maybe Elem
(!) ctx@(Ctx m) el =
  if (member ctx el)
    then Just (m M.! (elemId el))
    else Nothing

{- | Merges two Contexts. If there are clashes return Left Elem which indicates
     which element was the culprit. Otherwise return Right Ctx. -}
merge :: Ctx -> Ctx -> Either (Elem, Elem) (Ctx)
merge (Ctx m1) (Ctx m2) =
  let intersection = (M.intersection m1 m2) in
  if (M.null intersection)
    then Right (Ctx (M.union m1 m2))
    else
      let key = head (M.keys intersection) in
      Left (m1 M.! key, m2 M.! key)

-----------------------------------------------------------------------------