{- |

Module : $Header$

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 Text.ParserCombinators.Parsec

getGlobalAnnos :: String -> Result GlobalAnnos

getGlobalAnnos istr = let str = trimLeft istr in

case runParser (annotations << eof) () "" str of

Left err -> 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))