content: {-# LANGUAGE DeriveDataTypeable #-}
  {- |
  Module      :  ./Common/Prec.hs
  Description :  precedence checking
  Copyright   :  Christian Maeder and Uni Bremen 2006
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  experimental
  Portability :  portable
  
  Precedence checking
  -}
  
  module Common.Prec where
  
  import Common.Id
  import Common.GlobalAnnotations
  import Common.AS_Annotation
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  import qualified Common.Lib.Rel as Rel
  
  import Data.Data
  import Data.Maybe
  import Data.List (partition)
  
  -- | a precedence map using numbers for faster lookup
  data PrecMap = PrecMap
      { precMap :: Map.Map Id Int
      , maxWeight :: Int
      } deriving (Show, Typeable, Data)
  
  emptyPrecMap :: PrecMap
  emptyPrecMap = PrecMap
      { precMap = Map.empty
      , maxWeight = 0
      }
  
  mkPrecIntMap :: Rel.Rel Id -> PrecMap
  mkPrecIntMap r =
      let (m, t) = Rel.toPrecMap r
          in emptyPrecMap
                 { precMap = m
                 , maxWeight = t
                 }
  
  getIdPrec :: PrecMap -> Set.Set Id -> Id -> Int
  getIdPrec p ps i = let PrecMap m mx = p in
      if i == applId then mx + 1
      else Map.findWithDefault
      (if begPlace i || endPlace i then
           if Set.member i ps then Map.findWithDefault (div mx 2) eqId m else mx
       else mx + 2) i m
  
  getSimpleIdPrec :: PrecMap -> Id -> Int
  getSimpleIdPrec p = getIdPrec p Set.empty
  
  -- | drop as many elements as are in the first list
  dropPrefix :: [a] -> [b] -> [b]
  dropPrefix [] l = l
  dropPrefix _ [] = []
  dropPrefix (_ : xs) (_ : ys) = dropPrefix xs ys
  
  {- | check if a left argument will be added.
  (The 'Int' is the number of current arguments.) -}
  isLeftArg :: Id -> [a] -> Bool
  isLeftArg op nArgs = null nArgs && begPlace op
  
  -- | check if a right argument will be added.
  isRightArg :: Id -> [a] -> Bool
  isRightArg op@(Id toks _ _) nArgs = endPlace op
    && isSingle (dropPrefix nArgs
    $ filter (`elem` [placeTok, typeInstTok]) toks)
  
  joinPlace :: AssocEither -> Id -> Bool
  joinPlace side = case side of
      ALeft -> begPlace
      ARight -> endPlace
  
  checkArg :: AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
  checkArg side ga (op, opPrec) (arg, argPrec) weight =
      let precs = prec_annos ga
          junction = joinPlace side arg
          sop = stripPoly op
          assocCond b = if stripPoly arg == sop
            then not $ isAssoc side (assoc_annos ga) sop else b
      in argPrec > 0 &&
         case compare argPrec opPrec of
             LT -> not junction && op /= applId
             GT -> True
             EQ -> not junction ||
                 case precRel precs sop $ stripPoly weight of
                 Lower -> True
                 Higher -> False
                 BothDirections -> assocCond False
                 NoDirection ->
                     case (isInfix arg, joinPlace side op) of
                          (True, True) -> assocCond True
                          (False, True) -> True
                          (True, False) -> False
                          _ -> side == ALeft
  
  -- | compute the left or right weight for the application
  nextWeight :: AssocEither -> GlobalAnnos -> Id -> Id -> Id
  nextWeight side ga arg op =
         if joinPlace side arg then
            case precRel (prec_annos ga) (stripPoly op) $ stripPoly arg of
              Higher -> arg
              _ -> op
         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
    | isLeftArg o args = checkArg ARight ga op arg (weight ARight)
    | isRightArg o args = checkArg ALeft ga op arg (weight ALeft)
    | otherwise = True
  
  -- | token for instantiation lists of polymorphic operations
  typeInstTok :: Token
  typeInstTok = mkSimpleId "[type ]"
  
  -- | mark an identifier as polymorphic with a `typeInstTok` token
  polyId :: Id -> Id
  polyId (Id ts cs ps) = let (toks, pls) = splitMixToken ts in
      Id (toks ++ [typeInstTok] ++ pls) cs ps
  
  -- | remove the `typeInstTok` token again
  unPolyId :: Id -> Maybe Id
  unPolyId (Id ts cs ps) = let (ft, rt) = partition (== typeInstTok) ts in
      case ft of
        [_] -> Just $ Id rt cs ps
        _ -> Nothing
  
  stripPoly :: Id -> Id
  stripPoly w = fromMaybe w $ unPolyId w
  
  -- | get the token lists for polymorphic ids
  getGenPolyTokenList :: String -> Id -> [Token]
  getGenPolyTokenList str (Id ts cs ps) =
      let (toks, pls) = splitMixToken ts in
      getTokenList str (Id toks cs ps) ++
      typeInstTok : getTokenList str (Id pls [] ps)
  