{-# 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 Id Int
precMap :: Map.Map Id Int
    , PrecMap -> Int
maxWeight :: Int
    } deriving (Int -> PrecMap -> ShowS
[PrecMap] -> ShowS
PrecMap -> String
(Int -> PrecMap -> ShowS)
-> (PrecMap -> String) -> ([PrecMap] -> ShowS) -> Show PrecMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrecMap] -> ShowS
$cshowList :: [PrecMap] -> ShowS
show :: PrecMap -> String
$cshow :: PrecMap -> String
showsPrec :: Int -> PrecMap -> ShowS
$cshowsPrec :: Int -> PrecMap -> ShowS
Show, Typeable, Typeable PrecMap
Constr
DataType
Typeable PrecMap =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> PrecMap -> c PrecMap)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c PrecMap)
-> (PrecMap -> Constr)
-> (PrecMap -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c PrecMap))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PrecMap))
-> ((forall b. Data b => b -> b) -> PrecMap -> PrecMap)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> PrecMap -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> PrecMap -> r)
-> (forall u. (forall d. Data d => d -> u) -> PrecMap -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> PrecMap -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap)
-> Data PrecMap
PrecMap -> Constr
PrecMap -> DataType
(forall b. Data b => b -> b) -> PrecMap -> PrecMap
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PrecMap -> c PrecMap
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PrecMap
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PrecMap -> u
forall u. (forall d. Data d => d -> u) -> PrecMap -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PrecMap
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PrecMap -> c PrecMap
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PrecMap)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PrecMap)
$cPrecMap :: Constr
$tPrecMap :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
gmapMp :: (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
gmapM :: (forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PrecMap -> m PrecMap
gmapQi :: Int -> (forall d. Data d => d -> u) -> PrecMap -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PrecMap -> u
gmapQ :: (forall d. Data d => d -> u) -> PrecMap -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PrecMap -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PrecMap -> r
gmapT :: (forall b. Data b => b -> b) -> PrecMap -> PrecMap
$cgmapT :: (forall b. Data b => b -> b) -> PrecMap -> PrecMap
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PrecMap)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PrecMap)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c PrecMap)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PrecMap)
dataTypeOf :: PrecMap -> DataType
$cdataTypeOf :: PrecMap -> DataType
toConstr :: PrecMap -> Constr
$ctoConstr :: PrecMap -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PrecMap
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PrecMap
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PrecMap -> c PrecMap
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PrecMap -> c PrecMap
$cp1Data :: Typeable PrecMap
Data)

emptyPrecMap :: PrecMap
emptyPrecMap :: PrecMap
emptyPrecMap = PrecMap :: Map Id Int -> Int -> PrecMap
PrecMap
    { precMap :: Map Id Int
precMap = Map Id Int
forall k a. Map k a
Map.empty
    , maxWeight :: Int
maxWeight = 0
    }

mkPrecIntMap :: Rel.Rel Id -> PrecMap
mkPrecIntMap :: Rel Id -> PrecMap
mkPrecIntMap r :: Rel Id
r =
    let (m :: Map Id Int
m, t :: Int
t) = Rel Id -> (Map Id Int, Int)
forall a. Ord a => Rel a -> (Map a Int, Int)
Rel.toPrecMap Rel Id
r
        in PrecMap
emptyPrecMap
               { precMap :: Map Id Int
precMap = Map Id Int
m
               , maxWeight :: Int
maxWeight = Int
t
               }

getIdPrec :: PrecMap -> Set.Set Id -> Id -> Int
getIdPrec :: PrecMap -> Set Id -> Id -> Int
getIdPrec p :: PrecMap
p ps :: Set Id
ps i :: Id
i = let PrecMap m :: Map Id Int
m mx :: Int
mx = PrecMap
p in
    if Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
applId then Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
    else Int -> Id -> Map Id Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
    (if Id -> Bool
begPlace Id
i Bool -> Bool -> Bool
|| Id -> Bool
endPlace Id
i then
         if Id -> Set Id -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Id
i Set Id
ps then Int -> Id -> Map Id Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
mx 2) Id
eqId Map Id Int
m else Int
mx
     else Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Id
i Map Id Int
m

getSimpleIdPrec :: PrecMap -> Id -> Int
getSimpleIdPrec :: PrecMap -> Id -> Int
getSimpleIdPrec p :: PrecMap
p = PrecMap -> Set Id -> Id -> Int
getIdPrec PrecMap
p Set Id
forall a. Set a
Set.empty

-- | drop as many elements as are in the first list
dropPrefix :: [a] -> [b] -> [b]
dropPrefix :: [a] -> [b] -> [b]
dropPrefix [] l :: [b]
l = [b]
l
dropPrefix _ [] = []
dropPrefix (_ : xs :: [a]
xs) (_ : ys :: [b]
ys) = [a] -> [b] -> [b]
forall a b. [a] -> [b] -> [b]
dropPrefix [a]
xs [b]
ys

{- | check if a left argument will be added.
(The 'Int' is the number of current arguments.) -}
isLeftArg :: Id -> [a] -> Bool
isLeftArg :: Id -> [a] -> Bool
isLeftArg op :: Id
op nArgs :: [a]
nArgs = [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
nArgs Bool -> Bool -> Bool
&& Id -> Bool
begPlace Id
op

-- | check if a right argument will be added.
isRightArg :: Id -> [a] -> Bool
isRightArg :: Id -> [a] -> Bool
isRightArg op :: Id
op@(Id toks :: [Token]
toks _ _) nArgs :: [a]
nArgs = Id -> Bool
endPlace Id
op
  Bool -> Bool -> Bool
&& [Token] -> Bool
forall a. [a] -> Bool
isSingle ([a] -> [Token] -> [Token]
forall a b. [a] -> [b] -> [b]
dropPrefix [a]
nArgs
  ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter (Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token
placeTok, Token
typeInstTok]) [Token]
toks)

joinPlace :: AssocEither -> Id -> Bool
joinPlace :: AssocEither -> Id -> Bool
joinPlace side :: AssocEither
side = case AssocEither
side of
    ALeft -> Id -> Bool
begPlace
    ARight -> Id -> Bool
endPlace

checkArg :: AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
checkArg :: AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
checkArg side :: AssocEither
side ga :: GlobalAnnos
ga (op :: Id
op, opPrec :: Int
opPrec) (arg :: Id
arg, argPrec :: Int
argPrec) weight :: Id
weight =
    let precs :: Rel Id
precs = GlobalAnnos -> Rel Id
prec_annos GlobalAnnos
ga
        junction :: Bool
junction = AssocEither -> Id -> Bool
joinPlace AssocEither
side Id
arg
        sop :: Id
sop = Id -> Id
stripPoly Id
op
        assocCond :: Bool -> Bool
assocCond b :: Bool
b = if Id -> Id
stripPoly Id
arg Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
sop
          then Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ AssocEither -> AssocMap -> Id -> Bool
isAssoc AssocEither
side (GlobalAnnos -> AssocMap
assoc_annos GlobalAnnos
ga) Id
sop else Bool
b
    in Int
argPrec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&&
       case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
argPrec Int
opPrec of
           LT -> Bool -> Bool
not Bool
junction Bool -> Bool -> Bool
&& Id
op Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
applId
           GT -> Bool
True
           EQ -> Bool -> Bool
not Bool
junction Bool -> Bool -> Bool
||
               case Rel Id -> Id -> Id -> PrecRel
precRel Rel Id
precs Id
sop (Id -> PrecRel) -> Id -> PrecRel
forall a b. (a -> b) -> a -> b
$ Id -> Id
stripPoly Id
weight of
               Lower -> Bool
True
               Higher -> Bool
False
               BothDirections -> Bool -> Bool
assocCond Bool
False
               NoDirection ->
                   case (Id -> Bool
isInfix Id
arg, AssocEither -> Id -> Bool
joinPlace AssocEither
side Id
op) of
                        (True, True) -> Bool -> Bool
assocCond Bool
True
                        (False, True) -> Bool
True
                        (True, False) -> Bool
False
                        _ -> AssocEither
side AssocEither -> AssocEither -> Bool
forall a. Eq a => a -> a -> Bool
== AssocEither
ALeft

-- | compute the left or right weight for the application
nextWeight :: AssocEither -> GlobalAnnos -> Id -> Id -> Id
nextWeight :: AssocEither -> GlobalAnnos -> Id -> Id -> Id
nextWeight side :: AssocEither
side ga :: GlobalAnnos
ga arg :: Id
arg op :: Id
op =
       if AssocEither -> Id -> Bool
joinPlace AssocEither
side Id
arg then
          case Rel Id -> Id -> Id -> PrecRel
precRel (GlobalAnnos -> Rel Id
prec_annos GlobalAnnos
ga) (Id -> Id
stripPoly Id
op) (Id -> PrecRel) -> Id -> PrecRel
forall a b. (a -> b) -> a -> b
$ Id -> Id
stripPoly Id
arg of
            Higher -> Id
arg
            _ -> Id
op
       else Id
op

-- | check precedence of an argument and a top-level operator.
checkPrec :: GlobalAnnos -> (Id, Int) -> (Id, Int) -> [a]
  -> (AssocEither -> Id) -> Bool
checkPrec :: GlobalAnnos
-> (Id, Int) -> (Id, Int) -> [a] -> (AssocEither -> Id) -> Bool
checkPrec ga :: GlobalAnnos
ga op :: (Id, Int)
op@(o :: Id
o, _) arg :: (Id, Int)
arg args :: [a]
args weight :: AssocEither -> Id
weight
  | Id -> [a] -> Bool
forall a. Id -> [a] -> Bool
isLeftArg Id
o [a]
args = AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
checkArg AssocEither
ARight GlobalAnnos
ga (Id, Int)
op (Id, Int)
arg (AssocEither -> Id
weight AssocEither
ARight)
  | Id -> [a] -> Bool
forall a. Id -> [a] -> Bool
isRightArg Id
o [a]
args = AssocEither -> GlobalAnnos -> (Id, Int) -> (Id, Int) -> Id -> Bool
checkArg AssocEither
ALeft GlobalAnnos
ga (Id, Int)
op (Id, Int)
arg (AssocEither -> Id
weight AssocEither
ALeft)
  | Bool
otherwise = Bool
True

-- | token for instantiation lists of polymorphic operations
typeInstTok :: Token
typeInstTok :: Token
typeInstTok = String -> Token
mkSimpleId "[type ]"

-- | mark an identifier as polymorphic with a `typeInstTok` token
polyId :: Id -> Id
polyId :: Id -> Id
polyId (Id ts :: [Token]
ts cs :: [Id]
cs ps :: Range
ps) = let (toks :: [Token]
toks, pls :: [Token]
pls) = [Token] -> ([Token], [Token])
splitMixToken [Token]
ts in
    [Token] -> [Id] -> Range -> Id
Id ([Token]
toks [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
typeInstTok] [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token]
pls) [Id]
cs Range
ps

-- | remove the `typeInstTok` token again
unPolyId :: Id -> Maybe Id
unPolyId :: Id -> Maybe Id
unPolyId (Id ts :: [Token]
ts cs :: [Id]
cs ps :: Range
ps) = let (ft :: [Token]
ft, rt :: [Token]
rt) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
typeInstTok) [Token]
ts in
    case [Token]
ft of
      [_] -> Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ [Token] -> [Id] -> Range -> Id
Id [Token]
rt [Id]
cs Range
ps
      _ -> Maybe Id
forall a. Maybe a
Nothing

stripPoly :: Id -> Id
stripPoly :: Id -> Id
stripPoly w :: Id
w = Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
w (Maybe Id -> Id) -> Maybe Id -> Id
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
unPolyId Id
w

-- | get the token lists for polymorphic ids
getGenPolyTokenList :: String -> Id -> [Token]
getGenPolyTokenList :: String -> Id -> [Token]
getGenPolyTokenList str :: String
str (Id ts :: [Token]
ts cs :: [Id]
cs ps :: Range
ps) =
    let (toks :: [Token]
toks, pls :: [Token]
pls) = [Token] -> ([Token], [Token])
splitMixToken [Token]
ts in
    String -> Id -> [Token]
getTokenList String
str ([Token] -> [Id] -> Range -> Id
Id [Token]
toks [Id]
cs Range
ps) [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++
    Token
typeInstTok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> Id -> [Token]
getTokenList String
str ([Token] -> [Id] -> Range -> Id
Id [Token]
pls [] Range
ps)