content: {- |
  Module      :  ./Common/AnalyseAnnos.hs
  Description :  analyse annotations and add them to global ones
  Copyright   :  (c) Christian Maeder, Klaus Luettich and Uni Bremen 2002-2003
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  Some functions for building and accessing the datastructures of
   GlobalAnnotations
  -}
  
  module Common.AnalyseAnnos
    ( addGlobalAnnos
    , getGlobalAnnos
    , store_literal_map
    ) where
  
  import Common.AnnoParser
  import Common.AS_Annotation
  import Common.DocUtils
  import Common.GlobalAnnotations
  import Common.Id
  import Common.Lexer
  import Common.Parsec
  import Common.Result
  import Common.Utils
  import qualified Common.Lib.Rel as Rel
  
  import qualified Data.Map as Map
  import Data.Maybe (fromMaybe)
  import Data.List (partition)
  import Control.Monad (foldM)
  import qualified Control.Monad.Fail as Fail
  import Text.ParserCombinators.Parsec
  
  getGlobalAnnos :: String -> Result GlobalAnnos
  getGlobalAnnos istr = let str = trimLeft istr in
    case runParser (annotations << eof) () "" str of
      Left err -> Fail.fail $ show err
      Right ans -> addGlobalAnnos emptyGlobalAnnos ans
  
  -- | add global annotations
  addGlobalAnnos :: GlobalAnnos -> [Annotation] -> Result GlobalAnnos
  addGlobalAnnos ga all_annos = do
    let (annos, rest_annos) = partition ( \ a -> case a of
          Label _ _ -> False
          Semantic_anno _ _ -> False
          Unparsed_anno {} -> False
              -- line and group and comments will be ignored
          _ -> True) all_annos
    appendDiags $ map (mkDiag Hint "no analysis of") rest_annos
    n_prec_annos <- store_prec_annos (prec_annos ga) annos
    n_assoc_annos <- store_assoc_annos (assoc_annos ga) annos
    n_display_annos <- store_display_annos (display_annos ga) annos
    n_literal_annos <- store_literal_annos (literal_annos ga) annos
    n_literal_map <- store_literal_map (literal_map ga) annos
    n_prefix_map <- store_prefix_map (prefix_map ga) annos
    return ga
      { prec_annos = n_prec_annos
      , assoc_annos = n_assoc_annos
      , display_annos = n_display_annos
      , literal_annos = n_literal_annos
      , literal_map = n_literal_map
      , prefix_map = n_prefix_map }
  
  -- | add precedences
  store_prec_annos :: PrecedenceGraph -> [Annotation] -> Result PrecedenceGraph
  store_prec_annos pgr =
    let showRel = showSepList (showString "\n") showIdPair . Rel.toList in
      fmap Rel.transClosure . foldM ( \ p0 an -> case an of
        Prec_anno prc lIds hIds _ -> foldM (\ p1 li ->
          foldM ( \ p2 hi -> if li == hi
            then Result [mkDiag Error "prec_anno with equal id" hi] $ Just p2
            else let
              err rel = Result [mkDiag Error
                ("prec_anno conflict: " ++ showId li rel ++ showId hi "\n"
                 ++ showRel p2 "") hi] $ Just p2
              in case prc of
            Lower -> if Rel.path hi li p2
              then err " < "
              else return (Rel.insertPair li hi p2)
            BothDirections -> if Rel.path hi li p2 == Rel.path li hi p2
              then return (Rel.insertPair hi li (Rel.insertPair li hi p2))
              else err " <> "
            _ -> err " > ") p1 hIds) p0 lIds
        _ -> return p0) pgr
  
  -- | add associative ids
  store_assoc_annos :: AssocMap -> [Annotation] -> Result AssocMap
  store_assoc_annos = foldM $ \ am0 an -> case an of
    Assoc_anno as is _ -> foldM ( \ am1 i ->
      let v = Map.lookup i am1 in case v of
        Nothing -> return $ Map.insert i as am1
        Just os -> Result
          [ if as == os
            then mkDiag Hint "repeated associative identifier" i
            else mkDiag Error "identifier has already other associativity" i ]
          $ Just am1 ) am0 is
    _ -> return am0
  
  -- | add display annotations
  store_display_annos :: DisplayMap -> [Annotation] -> Result DisplayMap
  store_display_annos = foldM $ \ m an -> case an of
    Display_anno i sxs _ -> do
      let t = Map.findWithDefault Map.empty i m
      dm <- foldM ( \ table (df, str) -> do
        let Result ds mres = parse_display_str an str
            toks = fromMaybe [] mres
            oldToks = Map.findWithDefault toks df table
            checkToks =
              [ mkDiag Error
                ("Number of places in identifier \"" ++ showId i
                " \" does not meet number of places in display string \""
                 ++ str ++ "\"") an
              | placeCount i /= placeCount (mkId toks) ]
        appendDiags ds
        if oldToks == toks then do
            appendDiags checkToks
            return $ Map.insert df toks table
          else do
            appendDiags [mkDiag Error ("conflict: " ++ showDoc an "") an]
            return table) t sxs
      return $ Map.insert i dm m
    _ -> return m
  
  {- | add literal annotation to 'LiteralMap'
  and check for overlapping ids -}
  store_literal_map :: LiteralMap -> [Annotation] -> Result LiteralMap
  store_literal_map = foldM $ \ m a -> case a of
    Number_anno id1 _ ->
        let oc = Map.findWithDefault Number id1 m in
        if oc == Number -- repeated or new
        then return $ Map.insert id1 Number m
        else Result [mkDiag Error ("conflict: " ++ showDoc a "") id1] $ Just m
    String_anno id1 id2 _ ->
        let c = StringCons id1
            oc = Map.findWithDefault c id2 m
            on = Map.findWithDefault StringNull id1 m
        in if oc == c && on == StringNull
        then return $ Map.insert id1 StringNull $ Map.insert id2 c m
        else Result [mkDiag Error ("conflict: " ++ showDoc a "") id1] $ Just m
    Float_anno id1 id2 _ ->
        let oc = Map.findWithDefault Fraction id1 m
            on = Map.findWithDefault Floating id2 m
        in if oc == Fraction && on == Floating
        then return $ Map.insert id2 Floating $ Map.insert id1 Fraction m
        else Result [mkDiag Error ("conflict: " ++ showDoc a "") id1] $ Just m
    List_anno id1 id2 id3 _ ->
        let c = ListCons id1 id2
            n = ListNull id1
            oc = Map.findWithDefault c id3 m
            on = Map.findWithDefault n id2 m
        in if c == oc && n == on
           then return $ Map.insert id2 n $ Map.insert id3 c m
           else Result [mkDiag Error ("conflict: " ++ showDoc a "") id1] $ Just m
    _ -> return m
  
  -- | add prefix annotation to 'PrefixMap'
  store_prefix_map :: PrefixMap -> [Annotation] -> Result PrefixMap
  store_prefix_map = foldM $ \ m a -> case a of
    Prefix_anno assoc _ ->
        let newPrefixesMap = Map.fromList assoc in
        return $ Map.unionWith (\ _ p2 -> p2) m newPrefixesMap
    _ -> return m
  
  {- | add literal annotation to 'LiteralAnnos'
  and check for contradictions -}
  store_literal_annos :: LiteralAnnos -> [Annotation] -> Result LiteralAnnos
  store_literal_annos la ans = do
    n_string_lit <- setStringLit (string_lit la) ans
    n_list_lit <- setListLit (list_lit la) ans
    n_number_lit <- setNumberLit (number_lit la) ans
    n_float_lit <- setFloatLit (float_lit la) ans
    return la
      { string_lit = n_string_lit
      , list_lit = n_list_lit
      , number_lit = n_number_lit
      , float_lit = n_float_lit }
  
  -- | shortcut to show errors in 'setStringLit' and  'setFloatLit'
  showIdPair :: (Id, Id) -> ShowS
  showIdPair (i1, i2) = showId i1 . showString "," . showId i2
  
  -- | add (and check for uniqueness) string annotations
  setStringLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
  setStringLit = foldM $ \ m a -> case a of
    String_anno id1 id2 _ -> let q = (id1, id2) in case m of
      Nothing -> return $ Just q
      Just p -> if q == p then return m
        else Result [mkDiag Error
          ("conflict %string " ++ showIdPair q " and " ++ showIdPair p "") id1]
        $ Just m
    _ -> return m
  
  -- | add (and check for uniqueness) floating annotations
  setFloatLit :: Maybe (Id, Id) -> [Annotation] -> Result (Maybe (Id, Id))
  setFloatLit = foldM $ \ m a -> case a of
    Float_anno id1 id2 _ -> let q = (id1, id2) in case m of
      Nothing -> return $ Just q
      Just p -> if q == p then return m
        else Result [mkDiag Error
         ("conflict %floating  " ++ showIdPair q " and " ++ showIdPair p "") id1]
        $ Just m
    _ -> return m
  
  -- | add (and check for uniqueness) number annotations
  setNumberLit :: Maybe Id -> [Annotation] -> Result (Maybe Id)
  setNumberLit = foldM $ \ m a -> case a of
    Number_anno id1 _ -> case m of
      Nothing -> return $ Just id1
      Just id2 -> if id1 == id2 then return m
        else Result [mkDiag Error
          ("conflict %number " ++ showId id1 " and " ++ showId id2 "") id1]
        $ Just m
    _ -> return m
  
  -- | add (and check for consistency) (possibly several) list annotations
  setListLit :: Map.Map Id (Id, Id) -> [Annotation]
    -> Result (Map.Map Id (Id, Id))
  setListLit =
    let showListAnno i1 (i2, i3) =
            " %list " ++ showId i1 "," ++ showId i2 "," ++ showId i3 ""
    in foldM $ \ m a -> case a of
    List_anno id1 id2 id3 _ ->
             -- equal keys with different values conflict
      let nv = (id2, id3)
      in case Map.lookup id1 m of
           Nothing -> return $ Map.insert id1 nv m
           Just v -> if nv == v then return m
             else Result [mkDiag Error
               ("conflict" ++ showListAnno id1 nv ++ " and"
                ++ showListAnno id1 v) id1] $ Just m
    _ -> return m
  
  parse_display_str :: Annotation -> String -> Result [Token]
  parse_display_str an str =
    case parse tokenL "-- internal parse --" str of
      Left err -> let
            err' = "could not parse display string: using \""
                   ++ str ++ "\" as display token!\n" ++ show err
                   ++ "\nin:\n" ++ showDoc an ""
            in warning [mkSimpleId str] err' nullRange
      Right i' -> return i'
  
  tokenL :: CharParser st [Token]
  tokenL = many1 $ placeT
    <|> fmap mkSimpleId
        (anyChar <:> manyTill anyChar (lookAhead $ forget placeT <|> eof))
  