{- |
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 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))