4169N/A{- |

0N/AModule : $Header$

0N/ADescription : precedence checking

0N/ACopyright : Christian Maeder and Uni Bremen 2006

0N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

0N/A

0N/AMaintainer : Christian.Maeder@dfki.de

0N/AStability : experimental

0N/APortability : portable

0N/A

0N/APrecedence checking

0N/A-}

0N/A

0N/Amodule Common.Prec where

0N/A

0N/Aimport Common.Id

0N/Aimport Common.GlobalAnnotations

2362N/Aimport Common.AS_Annotation

2362N/Aimport qualified Data.Map as Map

2362N/Aimport qualified Data.Set as Set

1178N/Aimport qualified Common.Lib.Rel as Rel

4169N/A

0N/A-- | a precedence map using numbers for faster lookup

0N/Adata PrecMap = PrecMap

4033N/A { precMap :: Map.Map Id Int

4033N/A , maxWeight :: Int

0N/A } deriving Show

4033N/A

1178N/AemptyPrecMap :: PrecMap

1178N/AemptyPrecMap = PrecMap

1178N/A { precMap = Map.empty

4033N/A , maxWeight = 0

1178N/A }

1178N/A

4033N/AmkPrecIntMap :: Rel.Rel Id -> PrecMap

1178N/AmkPrecIntMap r =

1178N/A let (m, t) = Rel.toPrecMap r

4033N/A in emptyPrecMap

1178N/A { precMap = m

1178N/A , maxWeight = t

4033N/A }

1178N/A

1178N/AgetIdPrec :: PrecMap -> Set.Set Id -> Id -> Int

1178N/AgetIdPrec p ps i = let PrecMap m mx = p in

4033N/A if i == applId then mx + 1

0N/A else Map.findWithDefault

1178N/A (if begPlace i || endPlace i then

1178N/A if Set.member i ps then Map.findWithDefault (div mx 2) eqId m else mx

1178N/A else mx + 2) i m

1178N/A

4033N/AgetSimpleIdPrec :: PrecMap -> Id -> Int

1178N/AgetSimpleIdPrec p = getIdPrec p Set.empty

1178N/A

4033N/A-- | drop as many elements as are in the first list

4033N/AdropPrefix :: [a] -> [b] -> [b]

1178N/AdropPrefix [] l = l

1178N/AdropPrefix _ [] = []

1178N/AdropPrefix (_ : xs) (_ : ys) = dropPrefix xs ys

4033N/A

1178N/A-- | check if a left argument will be added.

0N/A-- (The 'Int' is the number of current arguments.)

0N/AisLeftArg :: Id -> [a] -> Bool

4033N/AisLeftArg op nArgs = null nArgs && begPlace op

1178N/A-- | check if a right argument will be added.

1178N/AisRightArg :: Id -> [a] -> Bool

4033N/AisRightArg op@(Id toks _ _) nArgs = endPlace op &&

1178N/A (isSingle $ dropPrefix nArgs $ filter isPlace toks)

4033N/A

0N/AjoinPlace :: AssocEither -> Id -> Bool

4033N/AjoinPlace side = case side of

1178N/A ALeft -> begPlace

4033N/A ARight -> endPlace

1178N/A

4033N/AcheckArg :: AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool

4033N/AcheckArg side ga (op, opPrec) (arg, argPrec) weight =

1178N/A let precs = prec_annos ga

1178N/A assocs = assoc_annos ga

1178N/A junction = joinPlace side arg

4033N/A in if argPrec <= 0 then False

4033N/A else case compare argPrec opPrec of

1178N/A LT -> not junction && op /= applId

4033N/A GT -> True

0N/A EQ -> if junction then

0N/A case precRel precs op weight of

1178N/A Lower -> True

0N/A Higher -> False

4033N/A BothDirections -> False

0N/A NoDirection ->

0N/A case (isInfix arg, joinPlace side op) of

1178N/A (True, True) -> if arg == op

0N/A then not $ isAssoc side assocs op

4033N/A else True

0N/A (False, True) -> True

0N/A (True, False) -> False

1178N/A _ -> side == ALeft

0N/A else True

4033N/A

0N/A-- | compute the left or right weight for the application

0N/AnextWeight :: AssocEither -> GlobalAnnos -> Id -> Id -> Id

0N/AnextWeight side ga arg op =

1178N/A if joinPlace side arg then

1178N/A case precRel (prec_annos ga) op arg of

0N/A Higher -> arg

0N/A _ -> op

0N/A else op

-- | check precedence of an argument and a top-level operator.

checkPrec :: GlobalAnnos -> (Id, Int) -> (Id, Int) -> [a] ->

(AssocEither -> Id) -> Bool

checkPrec ga op@(o, _) arg args weight =

if isLeftArg o args then checkArg ARight ga op arg (weight ARight)

else if isRightArg o args then checkArg ALeft ga op arg (weight ALeft)

else True