Merge remote-tracking branch 'origin/2047_change_to_ghc_8.6.5' into n…

…esy_patterns_test

Adl/Logic_Adl.hs

@@ -58,9 +58,10 @@ instance Sentences Adl
       print_named Adl = printNSen
       symKind Adl = show . pretty . sym_kind
 
+instance Semigroup Context where
+    (Context m1 l1) <> (Context m2 l2) = Context (mplus m1 m2) $ l1 ++ l2
 instance Monoid Context where
     mempty = Context Nothing []
-    mappend (Context m1 l1) (Context m2 l2) = Context (mplus m1 m2) $ l1 ++ l2
 
 instance Syntax Adl
     Context

CASL/Amalgamability.hs

@@ -89,7 +89,7 @@ ops diag =
         mkNodeOps n opId opTypes ol =
             ol ++ Set.fold (mkNodeOp n opId) [] opTypes
         appendOps ol (n, Sign { opMap = m }) =
-            ol ++ Map.foldWithKey (mkNodeOps n) [] (MapSet.toMap m)
+            ol ++ Map.foldrWithKey (mkNodeOps n) [] (MapSet.toMap m)
     in foldl appendOps [] (labNodes diag)
 
 
@@ -102,7 +102,7 @@ preds diag =
         mkNodePreds n predId predTypes pl =
             pl ++ Set.fold (mkNodePred n predId) [] predTypes
         appendPreds pl (n, Sign { predMap = m }) =
-            pl ++ Map.foldWithKey (mkNodePreds n) [] (MapSet.toMap m)
+            pl ++ Map.foldrWithKey (mkNodePreds n) [] (MapSet.toMap m)
     in foldl appendPreds [] (labNodes diag)
 
 

CASL/Disambiguate.hs

@@ -40,7 +40,7 @@ disambigSigExt extInd extEm sig =
       ss = sortSet sig
       sMap = Set.fold (`Map.insert` 1) Map.empty ss
       om = createOpMorMap $ disambOverloaded sMap mkPartial os
-      oMap = Map.foldWithKey (\ i ->
+      oMap = Map.foldrWithKey (\ i ->
              Map.insertWith (+) i . length) sMap os
       pm = Map.map fst $ disambOverloaded oMap id ps
   in (embedMorphism extEm sig $ inducedSignAux extInd Map.empty om pm extEm sig)
@@ -52,7 +52,7 @@ disambOverloaded :: Ord a => Map.Map Id Int
                -> Map.Map Id [Set.Set a]
                -> Map.Map (Id, a) (Id, a)
 disambOverloaded oMap g =
-  Map.foldWithKey (\ i l m ->
+  Map.foldrWithKey (\ i l m ->
     foldr (\ (s, n) m2 -> let j = mkOverloadedId n i in
       Set.fold (\ t -> Map.insert (i, g t) (j, t)) m2 s) m
     $ zip l [1 + Map.findWithDefault 0 i oMap ..])

CASL/Freeness.hs

@@ -722,7 +722,7 @@ quantifyUniversally form = if null var_decl
 {- | traverses a map with sorts as keys and sets of variables as value
 and creates a list of variable declarations -}
 listVarDecl :: Map.Map Id (Set.Set Token) -> [VAR_DECL]
-listVarDecl = Map.foldWithKey f []
+listVarDecl = Map.foldrWithKey f []
       where f sort var_set = (Var_decl (Set.toList var_set) sort nullRange :)
 
 -- | generates a new variable qualified with the given number

CASL/Logic_CASL.hs

@@ -114,9 +114,10 @@ instance (Ord f, Ord e, Ord m, MorphismExtension e m) =>
     isInclusion = isInclusionMorphism isInclusionMorphismExtension
     legal_mor = legalMor
 
+instance Semigroup (BASIC_SPEC b s f) where
+    (Basic_spec l1) <> (Basic_spec l2) = Basic_spec $ l1 ++ l2
 instance Monoid (BASIC_SPEC b s f) where
     mempty = Basic_spec []
-    mappend (Basic_spec l1) (Basic_spec l2) = Basic_spec $ l1 ++ l2
 
 -- abstract syntax, parsing (and printing)
 

CASL/Qualify.hs

@@ -56,7 +56,7 @@ qualifySigExt extInd extEm nodeId libId m sig = do
       sMap = Set.fold (`Map.insert` 1) Map.empty ss
       om = createOpMorMap $ qualOverloaded sMap (Map.map fst $ op_map m)
            nodeId libId (mapOpType sm) mkPartial os
-      oMap = Map.foldWithKey (\ i ->
+      oMap = Map.foldrWithKey (\ i ->
              Map.insertWith (+) i . Set.size) sMap $ MapSet.toMap os
       pm = Map.map fst $ qualOverloaded oMap (pred_map m) nodeId libId
            (mapPredType sm) id ps
@@ -69,7 +69,7 @@ qualOverloaded :: Ord a => Map.Map Id Int -> Map.Map (Id, a) Id -> SIMPLE_ID
                -> LibName -> (a -> a) -> (a -> a) -> MapSet.MapSet Id a
                -> Map.Map (Id, a) (Id, a)
 qualOverloaded oMap rn nodeId libId f g =
-  Map.foldWithKey (\ i s m -> foldr (\ (e, n) -> let ge = g e in
+  Map.foldrWithKey (\ i s m -> foldr (\ (e, n) -> let ge = g e in
     Map.insert (i, ge)
       (case Map.lookup (i, ge) rn of
          Just j | isQualName j -> j

CASL/SymbolMapAnalysis.hs

@@ -131,10 +131,10 @@ inducedFromMorphismExt extInd extEm rmap sigma = do
                 return $ if s' == s then m1 else Map.insert s s' m1)
               (return Map.empty) (sortSet sigma)
   -- compute the op map (as a Map)
-  op_Map <- Map.foldWithKey (opFun sigma rmap sort_Map)
+  op_Map <- Map.foldrWithKey (opFun sigma rmap sort_Map)
               (return Map.empty) (MapSet.toMap $ opMap sigma)
   -- compute the pred map (as a Map)
-  pred_Map <- Map.foldWithKey (predFun sigma rmap sort_Map)
+  pred_Map <- Map.foldrWithKey (predFun sigma rmap sort_Map)
               (return Map.empty) (MapSet.toMap $ predMap sigma)
   em <- extEm rmap $ extendedInfo sigma
   -- return assembled morphism

CASL/Taxonomy.hs

@@ -72,7 +72,7 @@ convSign KSubsort onto sign =
 convPred :: Sign f e -> MMiSSOntology -> WithError MMiSSOntology
 convPred s o =
     -- first only binary preds; later also unary preds
-    Map.foldWithKey addPred (hasValue o) $ MapSet.toMap $ predMap s
+    Map.foldrWithKey addPred (hasValue o) $ MapSet.toMap $ predMap s
     where addPred pn tSet wOnto =
            weither (const wOnto) insBinaryPred wOnto
            where insBinaryPred on =

CASL/ToSExpr.hs

@@ -149,14 +149,14 @@ morToSExprs m =
       sm = sort_map m
   in map (\ (s, t) -> SList [SSymbol "map", sortToSSymbol s, sortToSSymbol t])
      (Map.toList sm)
-     ++ Map.foldWithKey (\ i s -> case Set.toList s of
+     ++ Map.foldrWithKey (\ i s -> case Set.toList s of
           [] -> id
           ot : _ -> let (j, nt) = mapOpSym sm (op_map m) (i, ot) in
              if i == j then id else
                (SList [ SSymbol "map", opIdToSSymbol src i ot
                       , opIdToSSymbol tar j nt] :)) []
         (MapSet.toMap $ opMap src)
-     ++ Map.foldWithKey (\ i s -> case Set.toList s of
+     ++ Map.foldrWithKey (\ i s -> case Set.toList s of
           [] -> id
           ot : _ -> let (j, nt) = mapPredSym sm (pred_map m) (i, ot) in
              if i == j then id else

CASL/World.hs

@@ -76,7 +76,7 @@ modPredType ws term m = PredType $ (if term then (m :) else id) [ws, ws]
 
 -- | the renaming as part of a morphism
 renMorphism :: Ord a => (Id -> Id) -> MapSet.MapSet Id a -> Map.Map (Id, a) Id
-renMorphism ren = Map.foldWithKey (\ i s ->
+renMorphism ren = Map.foldrWithKey (\ i s ->
    let j = ren i in
    if j == i then id else
        Map.union . Map.fromAscList . map (\ a -> ((j, a), j)) $ Set.toList s)

CASL_DL/StatAna.hs

@@ -358,7 +358,7 @@ checkSymbolMapDL rsm =
     let checkSourceSymbol sSym _ =
               if any (`matches` sSym) symOfPredefinedSign then
                   (sSym :) else id
-        syms = Map.foldWithKey checkSourceSymbol [] rsm
+        syms = Map.foldrWithKey checkSourceSymbol [] rsm
     in if null syms
        then return rsm
        else mkError "Predefined CASL_DL symbols cannot be mapped" syms

CSL/EPElimination.hs

@@ -88,7 +88,7 @@ getBackRef d =
         -- for each entry in the set insert k into the list
         f k s m = Set.fold (uf k) m s
     -- from each entry in d add entries in the map
-    in Map.foldWithKey f Map.empty d
+    in Map.foldrWithKey f Map.empty d
 
 
 topsortDirect :: (Show a, Ord a) => Rel2 a -> [a]

CSL/EPRelation.hs

@@ -44,7 +44,7 @@ particularly for comparison -}
 type EPExps = Map.Map String EPExp
 
 evalEPs :: (String -> Int) -> EPExps -> Bool
-evalEPs f = Map.foldWithKey g True where
+evalEPs f = Map.foldrWithKey g True where
     g k v b = evalEP (f k) v && b
 
 prettyEPs :: EPExps -> Doc
@@ -366,7 +366,7 @@ compareEPs eps1 eps2 =
         We have to count the number of matched parameter names to see if
         there are still EPs in eps' which indicates to compare with ">" at
         the end of the fold. -}
-        (epc, cnt) = Map.foldWithKey f
+        (epc, cnt) = Map.foldrWithKey f
                      (Comparable EQ, 0) {- start the fold with "=",
                                         the identity element -}
                      eps -- the smaller map

CSL/Logic_CSL.hs

@@ -80,9 +80,10 @@ instance Sentences CSL CMD
     simplify_sen CSL _ = id
     symKind CSL _ = "op"
 
+instance Semigroup BASIC_SPEC where
+    (Basic_spec l1) <> (Basic_spec l2) = Basic_spec $ l1 ++ l2
 instance Monoid BASIC_SPEC where
     mempty = Basic_spec []
-    mappend (Basic_spec l1) (Basic_spec l2) = Basic_spec $ l1 ++ l2
 
 -- | Syntax of CSL logic
 instance Syntax CSL BASIC_SPEC Symbol

CSL/SMTComparison.hs

@@ -161,7 +161,7 @@ smtVarConstraint' :: VarEnv -> String
 smtVarConstraint' m = h l where
     h [] = ""
     h l' = concat ["(assert (and ", concat l' , "))"]
-    l = Map.foldWithKey f [] $ varmap m
+    l = Map.foldrWithKey f [] $ varmap m
     g k = case Map.lookup k $ vartypes m of
             Just br -> ' ' : smtBoolExp br
             Nothing -> ""
@@ -224,7 +224,7 @@ emptyVarEnv mHdl =  VarEnv { varmap = Map.empty
 
 -- | Type alias and subtype definitions for the domain of the extended params
 smtTypeDef :: VarEnv -> String
-smtTypeDef m = Map.foldWithKey f "" $ varmap m
+smtTypeDef m = Map.foldrWithKey f "" $ varmap m
     where g k a = case Map.lookup k $ vartypes m of
                     Just br ->
                         concat [ "(define-type t", show a, " (subtype (x"

CSMOF/Logic_CSMOF.hs

@@ -33,9 +33,10 @@ type Morphism = DefaultMorphism Sign
 
 -- CSMOF logic
 
+instance Semigroup Metamodel where
+  _ <> _ = error "Not implemented!"
 instance Monoid Metamodel where
   mempty = error "Not implemented!"
-  mappend _ _ = error "Not implemented!"
 
 instance Sentences CSMOF
   Sen

Common/Doc.hs

@@ -110,7 +110,7 @@ module Common.Doc
     , quotes
     , doubleQuotes
       -- * combining documents
-    , (<>)
+    -- , (<>)  -- exported via instance Semigroup Doc
     , (<+>)
     , hcat
     , hsep
@@ -205,8 +205,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
-infixl 6 <>
-infixl 6 <+>
+infixr 6 <+>
 infixl 5 $+$
 infixl 5 $++$
 
@@ -383,8 +382,8 @@ quotes d = hcat [quote, d, quote]
 doubleQuotes :: Doc -> Doc     -- ^ Wrap document in @\"...\"@
 doubleQuotes d = hcat [doubleQuote, d, doubleQuote]
 
-(<>) :: Doc -> Doc -> Doc      -- ^Beside
-a <> b = hcat [a, b]
+instance Semigroup Doc where
+  a <> b = hcat [a, b]
 
 rmEmpties :: [Doc] -> [Doc]
 rmEmpties = filter (not . isEmpty)

Common/GraphAlgo.hs

@@ -37,7 +37,7 @@ exampleGraph conns = Graph {
 }
 
 mapMin :: (a -> a -> Bool) -> Map.Map k a -> Maybe (k, a)
-mapMin less = Map.foldWithKey (\ k a b -> case b of
+mapMin less = Map.foldrWithKey (\ k a b -> case b of
  Just (_, a1) -> if less a1 a then b else Just (k, a)
  Nothing -> Just (k, a)) Nothing
 

Common/Lib/Graph.hs

@@ -137,7 +137,7 @@ clearPred v _ c = c { nodePreds = Map.delete v $ nodePreds c }
 updAdj :: Map.IntMap (GrContext a b) -> Map.IntMap [b]
        -> ([b] -> GrContext a b -> GrContext a b)
        -> Map.IntMap (GrContext a b)
-updAdj g m f = Map.foldWithKey (\ v -> updGrContext v . f) g m
+updAdj g m f = Map.foldrWithKey (\ v -> updGrContext v . f) g m
 
 updGrContext :: Node -> (GrContext a b -> GrContext a b)
              -> Map.IntMap (GrContext a b) -> Map.IntMap (GrContext a b)
@@ -158,7 +158,7 @@ composeGr v c (Gr g) = let
 getPaths :: Node -> Gr a b -> [[LEdge b]]
 getPaths src gr = case decomposeGr src gr of
     Just (c, ng) ->
-      Map.foldWithKey (\ nxt lbls l ->
+      Map.foldrWithKey (\ nxt lbls l ->
            l ++ map (\ b -> [(src, nxt, b)]) lbls
              ++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)
                            (getPaths nxt ng)) [] $ nodeSuccs c
@@ -168,7 +168,7 @@ getPaths src gr = case decomposeGr src gr of
 getAllPathsTo :: Node -> Gr a b -> [[LEdge b]]
 getAllPathsTo tgt gr = case decomposeGr tgt gr of
     Just (c, ng) ->
-      Map.foldWithKey (\ nxt lbls l ->
+      Map.foldrWithKey (\ nxt lbls l ->
            l ++ map (\ b -> [(nxt, tgt, b)]) lbls
              ++ concatMap (\ p -> map (\ b -> (nxt, tgt, b) : p) lbls)
                            (getAllPathsTo nxt ng)) [] $ nodePreds c
@@ -179,7 +179,7 @@ getPathsTo :: Node -> Node -> Gr a b -> [[LEdge b]]
 getPathsTo src tgt gr = case decomposeGr src gr of
     Just (c, ng) -> let
       s = nodeSuccs c
-      in Map.foldWithKey (\ nxt lbls ->
+      in Map.foldrWithKey (\ nxt lbls ->
             (++ concatMap (\ p -> map (\ b -> (src, nxt, b) : p) lbls)
                 (getPathsTo nxt tgt ng)))
           (map (\ lbl -> [(src, tgt, lbl)]) $ Map.findWithDefault [] tgt s)

Common/Lib/MapSet.hs

@@ -219,7 +219,7 @@ mapSet f = fromMap . Map.map f . toMap
 
 -- | fold over all elements
 foldWithKey :: (a -> b -> c -> c) -> c -> MapSet a b -> c
-foldWithKey f e = Map.foldWithKey (\ a bs c -> Set.fold (f a) c bs) e . toMap
+foldWithKey f e = Map.foldrWithKey (\ a bs c -> Set.fold (f a) c bs) e . toMap
 
 -- | filter elements
 filter :: (Ord a, Ord b) => (b -> Bool) -> MapSet a b -> MapSet a b
@@ -244,7 +244,7 @@ isSubmapOf (MapSet m) = Map.isSubmapOfBy Set.isSubsetOf m . toMap
 
 -- | pre-image of a map
 preImage :: (Ord a, Ord b) => Map.Map a b -> MapSet b a
-preImage = Map.foldWithKey (flip insert) empty
+preImage = Map.foldrWithKey (flip insert) empty
 
 -- | transpose a map set
 transpose :: (Ord a, Ord b) => MapSet a b -> MapSet b a

Common/Lib/Pretty.hs

@@ -221,7 +221,6 @@ import Prelude
 import Data.Monoid ( Monoid (mempty, mappend) )
 import Data.String ( IsString (fromString) )
 
-infixl 6 <>
 infixl 6 <+>
 infixl 5 $$, $+$
 
@@ -290,13 +289,15 @@ doubleQuotes :: Doc -> Doc;     -- ^ Wrap document in @\"...\"@
 
 -- Combining @Doc@ values
 
+instance Semigroup Doc where
+    p <> q = beside_ p False q
+
 instance Monoid Doc where
     mempty = empty
-    mappend = (<>)
 
 {- | Beside.
 '<>' is associative, with identity 'empty'. -}
-(<>) :: Doc -> Doc -> Doc
+-- (<>) :: Doc -> Doc -> Doc   -- see Semigroup instance above
 
 {- | Beside, separated by space, unless one of the arguments is 'empty'.
 '<+>' is associative, with identity 'empty'. -}
@@ -716,7 +717,6 @@ beside_ p _ Empty = p
 beside_ Empty _ q = q
 beside_ p g q = Beside p g q
 
-p <> q = beside_ p False q
 p <+> q = beside_ p True q
 
 beside :: Doc -> Bool -> RDoc -> RDoc

Common/Lib/Rel.hs

@@ -332,7 +332,7 @@ addCycle c r = if Set.null c then error "Common.Lib.Rel.addCycle" else
 -}
 haveCommonLeftElem :: Ord a => a -> a -> Rel a -> Bool
 haveCommonLeftElem t1 t2 =
-    Map.fold (\ e -> (|| Set.member t1 e && Set.member t2 e)) False . toMap
+    Map.foldr (\ e -> (|| Set.member t1 e && Set.member t2 e)) False . toMap
 
 {- | partitions a set into a list of disjoint non-empty subsets
 determined by the given function as equivalence classes -}

Common/Result.hs

@@ -57,6 +57,7 @@ import Common.Lexer
 
 import Control.Applicative
 import Control.Monad.Identity
+import qualified Control.Monad.Fail
 
 import Data.Data
 import Data.Function
@@ -155,6 +156,9 @@ instance MonadPlus Result where
                                  Nothing -> r2
                                  Just _ -> r1
 
+instance Control.Monad.Fail.MonadFail Result where
+  fail s = fatal_error s nullRange
+
 appendDiags :: [Diagnosis] -> Result ()
 appendDiags ds = Result ds (Just ())
 

Common/ResultT.hs

@@ -16,6 +16,7 @@ module Common.ResultT where
 import Common.Result
 import Control.Applicative
 import Control.Monad
+import qualified Control.Monad.Fail as MFail
 import Control.Monad.Trans
 
 newtype ResultT m a = ResultT { runResultT :: m (Result a) }
@@ -40,6 +41,9 @@ instance Monad m => Monad (ResultT m) where
                 return $ joinResult r s
     fail = ResultT . return . fail
 
+instance Monad m => MFail.MonadFail (ResultT m) where
+  fail = ResultT . return . fail
+
 instance MonadTrans ResultT where
     lift m = ResultT $ do
         a <- m

Common/Utils.hs

@@ -244,7 +244,7 @@ concatMapM f = liftM concat . mapM f
 -- | composition of arbitrary maps
 composeMap :: Ord a => Map.Map a b -> Map.Map a a -> Map.Map a a -> Map.Map a a
 composeMap s m1 m2 = if Map.null m2 then m1 else Map.intersection
-  (Map.foldWithKey ( \ i j ->
+  (Map.foldrWithKey ( \ i j ->
     let k = Map.findWithDefault j j m2 in
     if i == k then Map.delete i else Map.insert i k) m2 m1) s