content: {- |
  Module      :  ./HasCASL/RawSym.hs
  Description :  raw symbol functions
  Copyright   :  (c) Christian Maeder and Uni Bremen 2002-2003
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  raw symbols bridge symb items and the symbols of a signature
  -}
  
  module HasCASL.RawSym where
  
  import HasCASL.As
  import HasCASL.AsUtils
  import HasCASL.Builtin
  import HasCASL.ClassAna
  import HasCASL.Le
  import HasCASL.Merge (addUnit)
  import HasCASL.PrintLe (addClassMap)
  import HasCASL.VarDecl
  
  import Common.DocUtils
  import Common.Id
  import Common.Result
  import Common.Lib.State
  import qualified Data.Map as Map
  
  statSymbMapItems :: Env -> [SymbMapItems] -> Result RawSymbolMap
  statSymbMapItems e sl = do
      rs <- mapM ( \ (SymbMapItems kind l _ _)
                   -> mapM (symbOrMapToRaw e kind) l) sl
      foldr ( \ (r1, r2) mm -> do
              m <- mm
              if Map.member r1 m then do
                  Result [Diag Error ("duplicate mapping for: " ++
                            showDoc r1 "\n ignoring: " ++ showDoc r2 "")
                         $ posOfId $ rawSymName r2] $ Just ()
                  return m
                else return $ Map.insert r1 r2 m)
            (return Map.empty) $ concat rs
  
  symbOrMapToRaw :: Env -> SymbKind -> SymbOrMap -> Result (RawSymbol, RawSymbol)
  symbOrMapToRaw e k (SymbOrMap s mt _) = do
      s1 <- symbToRaw (Just e) k s
      s2 <- case mt of
        Nothing -> return s1
        Just t -> symbToRaw Nothing k t
      return (s1, s2)
  
  statSymbItems :: Env -> [SymbItems] -> Result [RawSymbol]
  statSymbItems e sl = do
    rs <- mapM (\ (SymbItems kind l _ _)
                -> mapM (symbToRaw (Just e) kind) l) sl
    return $ concat rs
  
  symbToRaw :: Maybe Env -> SymbKind -> Symb -> Result RawSymbol
  symbToRaw me k (Symb idt mt _) = case mt of
      Nothing -> return $ symbKindToRaw k idt
      Just (SymbType sc@(TypeScheme vs t _)) -> case me of
        Nothing ->
          hint (symbKindToRaw k idt) "ignoring target symbol qualification"
            $ getRange sc
        Just e ->
          let qi ty = ASymbol $ Symbol idt ty
              rsc = if k == SyKpred then predTypeScheme (posOfId idt) sc else sc
              r = do
                let cm = addClassMap cpoMap (classMap e)
                    (mtysc, rLe) = runState (anaTypeScheme rsc) e
                      { typeMap = addUnit cm $ typeMap e
                      , classMap = cm }
                case mtysc of
                  Nothing -> Result (reverse
                    $ mkDiag Error "no function type" rsc : envDiags rLe) Nothing
                  Just asc -> return $ qi $ OpAsItemType asc
              rk = if null vs then do
                  (_, ck) <- convTypeToKind t
                  maybeResult $ anaKindM ck $ classMap e
                else Nothing
          in case rk of
               Nothing -> case k of
                 Implicit -> r
                 SyKop -> r
                 SyKpred -> r
                 _ -> mkError "not a valid kind" t
               Just fk -> case k of
                 Implicit -> -- check here which symbol is in the signature
                   case maybeResult r of
                   Just sy -> return sy
                   _ -> return $ qi $ TypeAsItemType fk
                 SyKop -> r
                 SyKpred -> r
                 SyKclass -> return $ qi $ ClassAsItemType fk
                 _ -> return $ qi $ TypeAsItemType fk
  
  matchSymb :: Symbol -> RawSymbol -> Bool
  matchSymb sy rsy = let ty = symType sy in
    symName sy == rawSymName rsy && case rsy of
      AnID _ -> True
      AKindedId k _ -> symbTypeToKind ty == k
      ASymbol sy2 -> sy == sy2
  
  instance GetRange RawSymbol where
      getRange = getRange . rawSymName
  