Prec.hs revision 98890889ffb2e8f6f722b00e265a211f13b5a861
c208973c890b8f993297720fd0247bc7481d4304Christian MaederModule : $Header$
e9458b1a7a19a63aa4c179f9ab20f4d50681c168Jens ElknerDescription : precedence checking
c208973c890b8f993297720fd0247bc7481d4304Christian MaederCopyright : Christian Maeder and Uni Bremen 2006
c208973c890b8f993297720fd0247bc7481d4304Christian MaederLicense : GPLv2 or higher, see LICENSE.txt
c208973c890b8f993297720fd0247bc7481d4304Christian MaederMaintainer : Christian.Maeder@dfki.de
c208973c890b8f993297720fd0247bc7481d4304Christian MaederStability : experimental
dc21a74c78d138d5eba4a2b7c7965936f0892d77Christian MaederPortability : portable
c208973c890b8f993297720fd0247bc7481d4304Christian MaederPrecedence checking
c208973c890b8f993297720fd0247bc7481d4304Christian Maederimport qualified Data.Map as Map
c208973c890b8f993297720fd0247bc7481d4304Christian Maederimport qualified Data.Set as Set
c208973c890b8f993297720fd0247bc7481d4304Christian Maederimport qualified Common.Lib.Rel as Rel
c208973c890b8f993297720fd0247bc7481d4304Christian Maederimport Data.List (partition)
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder-- | a precedence map using numbers for faster lookup
c208973c890b8f993297720fd0247bc7481d4304Christian Maederdata PrecMap = PrecMap
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder { precMap :: Map.Map Id Int
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder , maxWeight :: Int
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder } deriving Show
c208973c890b8f993297720fd0247bc7481d4304Christian MaederemptyPrecMap :: PrecMap
c208973c890b8f993297720fd0247bc7481d4304Christian MaederemptyPrecMap = PrecMap
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder , maxWeight = 0
c208973c890b8f993297720fd0247bc7481d4304Christian MaedermkPrecIntMap :: Rel.Rel Id -> PrecMap
c208973c890b8f993297720fd0247bc7481d4304Christian MaedermkPrecIntMap r =
fa8878c6145f652f615a04a5e9c15a1d1327bc92cmaeder in emptyPrecMap
21bac9aa8d0fae4d14308065235814f653241357Christian Maeder { precMap = m
21bac9aa8d0fae4d14308065235814f653241357Christian Maeder , maxWeight = t
21bac9aa8d0fae4d14308065235814f653241357Christian MaedergetIdPrec :: PrecMap -> Set.Set Id -> Id -> Int
21bac9aa8d0fae4d14308065235814f653241357Christian MaedergetIdPrec p ps i = let PrecMap m mx = p in
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder if i == applId then mx + 1
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder (if begPlace i || endPlace i then
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder if Set.member i ps then Map.findWithDefault (div mx 2) eqId m else mx
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder else mx + 2) i m
c208973c890b8f993297720fd0247bc7481d4304Christian MaedergetSimpleIdPrec :: PrecMap -> Id -> Int
c208973c890b8f993297720fd0247bc7481d4304Christian MaedergetSimpleIdPrec p = getIdPrec p Set.empty
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder-- | drop as many elements as are in the first list
c208973c890b8f993297720fd0247bc7481d4304Christian MaederdropPrefix :: [a] -> [b] -> [b]
c208973c890b8f993297720fd0247bc7481d4304Christian MaederdropPrefix [] l = l
c208973c890b8f993297720fd0247bc7481d4304Christian MaederdropPrefix _ [] = []
c208973c890b8f993297720fd0247bc7481d4304Christian MaederdropPrefix (_ : xs) (_ : ys) = dropPrefix xs ys
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder-- | check if a left argument will be added.
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder-- (The 'Int' is the number of current arguments.)
c208973c890b8f993297720fd0247bc7481d4304Christian MaederisLeftArg :: Id -> [a] -> Bool
c208973c890b8f993297720fd0247bc7481d4304Christian MaederisLeftArg op nArgs = null nArgs && begPlace op
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder-- | check if a right argument will be added.
c208973c890b8f993297720fd0247bc7481d4304Christian MaederisRightArg :: Id -> [a] -> Bool
c208973c890b8f993297720fd0247bc7481d4304Christian MaederisRightArg op@(Id toks _ _) nArgs = endPlace op
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder && isSingle (dropPrefix nArgs
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder $ filter (flip elem [placeTok, typeInstTok]) toks)
c208973c890b8f993297720fd0247bc7481d4304Christian MaederjoinPlace :: AssocEither -> Id -> Bool
c208973c890b8f993297720fd0247bc7481d4304Christian MaederjoinPlace side = case side of
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder ALeft -> begPlace
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder ARight -> endPlace
c208973c890b8f993297720fd0247bc7481d4304Christian MaedercheckArg :: AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
c208973c890b8f993297720fd0247bc7481d4304Christian MaedercheckArg side ga (op, opPrec) (arg, argPrec) weight =
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder let precs = prec_annos ga
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder junction = joinPlace side arg
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder sop = stripPoly op
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder assocCond b = if stripPoly arg == sop
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder then not $ isAssoc side (assoc_annos ga) sop else b
c208973c890b8f993297720fd0247bc7481d4304Christian Maeder in if argPrec <= 0 then False
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder else case compare argPrec opPrec of
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder LT -> not junction && op /= applId
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder EQ -> if junction then
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder case precRel precs sop $ stripPoly weight of
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder Lower -> True
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder Higher -> False
fa8878c6145f652f615a04a5e9c15a1d1327bc92cmaeder BothDirections -> assocCond False
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder NoDirection ->
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder case (isInfix arg, joinPlace side op) of
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder (True, True) -> assocCond True
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder (False, True) -> True
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder (True, False) -> False
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder _ -> side == ALeft
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder-- | compute the left or right weight for the application
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedernextWeight :: AssocEither -> GlobalAnnos -> Id -> Id -> Id
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedernextWeight side ga arg op =
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder if joinPlace side arg then
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder case precRel (prec_annos ga) (stripPoly op) $ stripPoly arg of
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder Higher -> arg
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder-- | check precedence of an argument and a top-level operator.
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedercheckPrec :: GlobalAnnos -> (Id, Int) -> (Id, Int) -> [a]
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder -> (AssocEither -> Id) -> Bool
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedercheckPrec ga op@(o, _) arg args weight
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder | isLeftArg o args = checkArg ARight ga op arg (weight ARight)
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder | isRightArg o args = checkArg ALeft ga op arg (weight ALeft)
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder | otherwise = True
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian Maeder-- | token for instantiation lists of polymorphic operations
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedertypeInstTok :: Token
0d0278c34a374b29c2d6c58b39b8b56e283d48e8Christian MaedertypeInstTok = mkSimpleId "[type ]"
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder-- | mark an identifier as polymorphic with a `typeInstTok` token
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederpolyId :: Id -> Id
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederpolyId (Id ts cs ps) = let (toks, pls) = splitMixToken ts in
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder Id (toks ++ [typeInstTok] ++ pls) cs ps
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder-- | remove the `typeInstTok` token again
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederunPolyId :: Id -> Maybe Id
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederunPolyId (Id ts cs ps) = let (ft, rt) = partition (== typeInstTok) ts in
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder [_] -> Just $ Id rt cs ps
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederstripPoly :: Id -> Id
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaederstripPoly w = fromMaybe w $ unPolyId w
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder-- | get the token lists for polymorphic ids
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaedergetGenPolyTokenList :: String -> Id -> [Token]
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian MaedergetGenPolyTokenList str (Id ts cs ps) =
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder let (toks, pls) = splitMixToken ts in
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder getTokenList str (Id toks cs ps) ++
5fcf9c4aaca73698c4c220308c9fd5fc174ae334Christian Maeder typeInstTok : getTokenList str (Id pls [] ps)