Semigroup-Monoid Proposal fixes: GHC 8.4 compat

9 files changed, 80 insertions, 0 deletions

diff --git a/prototypes/FreeVars.hs b/prototypes/FreeVars.hs
index f0fb9a4b..32ad98a7 100644
--- a/prototypes/FreeVars.hs
+++ b/prototypes/FreeVars.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PatternGuards #-}
@@ -74,7 +75,12 @@ instance Num Nat where
 
 instance Monoid Nat where
     mempty = 0
+#if !MIN_VERSION_base(4,11,0)
     Nat a `mappend` Nat b = Nat (a + b)
+#else
+instance Semigroup Nat where
+    Nat a <> Nat b = Nat (a + b)
+#endif
 
 instance PShow Nat where pShow (Nat i) = pShow i
 instance Show Nat where show = ppShow
@@ -157,6 +163,7 @@ fromStr = fromBools . map (=='1')
 instance Monoid FV where
     mempty = FE
 
+#if !MIN_VERSION_base(4,11,0)
     mappend x FE = x
     mappend FE x = x
     mappend (FV a b us) (FV a' b' us')
@@ -166,6 +173,18 @@ instance Monoid FV where
         | otherwise        = fv c (a' + b' - c) $ mappend (FV 0 ((a + b) - (a' + b')) us) us'
       where
         c = min a a'
+#else
+instance Semigroup FV where
+    (<>)    x FE = x
+    (<>) FE x = x
+    (<>) (FV a b us) (FV a' b' us')
+        | a + b <= a'      = fv a b             $ us <> (FV (a' - (a + b)) b'     us')
+        | a + b - a' <= b' = fv c (a + b - c)   $ us <> (FV 0 (b' - (a + b - a')) us')
+        | a' + b' <= a     = fv a' b'           $ (FV (a - (a' + b')) b       us) <> us'
+        | otherwise        = fv c (a' + b' - c) $ (FV 0 ((a + b) - (a' + b')) us) <> us'
+      where
+        c = min a a'
+#endif
 
 prop_monoid_FV = prop_Monoid (T :: T FV)
 prop_mappend_normal_FV (a :: FV) b = testNormalFV (a <> b)
@@ -335,7 +354,12 @@ instance Arbitrary SFV where
 instance Monoid SFV where
     mempty = SFV 0 mempty
 
+#if !MIN_VERSION_base(4,11,0)
     SFV m b `mappend` SFV n a = SFV (n + m) $ sDrop n b <> a
+#else
+instance Semigroup SFV where
+    SFV m b <> SFV n a = SFV (n + m) $ sDrop n b <> a
+#endif
 
 prop_monoid_SFV = prop_Monoid (T :: T SFV)
 {-
diff --git a/prototypes/LamMachineV2.hs b/prototypes/LamMachineV2.hs
index 0d51d8a8..acacdf4b 100644
--- a/prototypes/LamMachineV2.hs
+++ b/prototypes/LamMachineV2.hs
@@ -3,6 +3,7 @@
 -- LamMachine is a variant of the machine described in
 -- "Deriving a Lazy Abstract Machine" (1997) by Peter Sestoft 
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PatternGuards #-}
@@ -192,7 +193,12 @@ newtype MDB = MDB {getMDB :: Int}
 
 instance Monoid MDB where
     mempty = MDB 0
+#if !MIN_VERSION_base(4,11,0)
     MDB n `mappend` MDB m = MDB $ n `max` m
+#else
+instance Semigroup MDB where
+    MDB n <> MDB m = MDB $ n `max` m
+#endif
 
 ------------------------------------- rearrange De Bruijn indices
 
diff --git a/prototypes/SplayList.hs b/prototypes/SplayList.hs
index 2cee0699..b2a8c743 100644
--- a/prototypes/SplayList.hs
+++ b/prototypes/SplayList.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -58,9 +59,16 @@ class (HasFV a, Measure a ~ Nat) => Measured a where
 
 instance Measured a => Monoid (SplayList a) where
     mempty  = Nil
+#if !MIN_VERSION_base(4,11,0)
     Nil `mappend` ys  = ys
     xs  `mappend` Nil = xs
     xs  `mappend` ys  = Append xs ys
+#else
+instance Semigroup (SplayList a) where
+    Nil <> ys  = ys
+    xs  <> Nil = xs
+    xs  <> ys  = Append xs ys
+#endif
 
 instance (Measured a, HasFV a) => HasFV (SplayList a) where
     fvLens = \case
diff --git a/prototypes/Stream.hs b/prototypes/Stream.hs
index e848fe36..b887f1ad 100644
--- a/prototypes/Stream.hs
+++ b/prototypes/Stream.hs
@@ -139,7 +139,12 @@ dbAnd a b = not <$> sOr (not <$> a) (not <$> b)
 
 instance Monoid (Stream Bool) where
     mempty = Repeat False
+#if !MIN_VERSION_base(4,11,0)
     mappend = sOr
+#else
+instance Semigroup (Stream Bool) where
+    (<>) = sOr
+#endif
 
 prop_StreamBool_monoid_left  (a :: Stream Bool)     = mempty <> a == a
 prop_StreamBool_monoid_right (a :: Stream Bool)     = a <> mempty == a
diff --git a/src/LambdaCube/Compiler/DeBruijn.hs b/src/LambdaCube/Compiler/DeBruijn.hs
index a0fd8326..a3d1d0fd 100644
--- a/src/LambdaCube/Compiler/DeBruijn.hs
+++ b/src/LambdaCube/Compiler/DeBruijn.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -76,7 +77,12 @@ instance PShow FreeVars where
 
 instance Monoid FreeVars where
     mempty = FreeVars 0
+#if !MIN_VERSION_base(4,11,0)
     FreeVars a `mappend` FreeVars b = FreeVars $ a .|. b
+#else
+instance Semigroup FreeVars where
+    FreeVars a <> FreeVars b = FreeVars $ a .|. b
+#endif
 
 freeVar :: Int -> FreeVars
 freeVar i = FreeVars $ 1 `shiftL` i
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index 4a556c32..2e967eff 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -148,10 +149,18 @@ instance Ord SI where _ `compare` _ = EQ
 
 instance Monoid SI where
     mempty = NoSI Set.empty
+#if !MIN_VERSION_base(4,11,0)
     mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2)
     mappend (NoSI ds1) (NoSI ds2) = NoSI  (ds1 `Set.union` ds2)
     mappend r@RangeSI{} _ = r
     mappend _ r@RangeSI{} = r
+#else
+instance Semigroup SI where
+    (<>) (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2)
+    (<>) (NoSI ds1) (NoSI ds2) = NoSI  (ds1 `Set.union` ds2)
+    (<>) r@RangeSI{} _ = r
+    (<>) _ r@RangeSI{} = r
+#endif
 
 instance PShow SI where
     pShow (NoSI ds) = hsep $ map text $ Set.toList ds
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 1ed8ac8c..70e7b98c 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -124,7 +125,12 @@ data DesugarInfo = DesugarInfo
 
 instance Monoid DesugarInfo where
     mempty = DesugarInfo mempty mempty mempty
+#if !MIN_VERSION_base(4,11,0)
     DesugarInfo a b c `mappend` DesugarInfo a' b' c' = DesugarInfo (a <> a') (b <> b') (c <> c')
+#else
+instance Semigroup DesugarInfo where
+    DesugarInfo a b c <> DesugarInfo a' b' c' = DesugarInfo (a <> a') (b <> b') (c <> c')
+#endif
 
 mkDesugarInfo :: [Stmt] -> DesugarInfo
 mkDesugarInfo ss = DesugarInfo
diff --git a/src/LambdaCube/Compiler/Patterns.hs b/src/LambdaCube/Compiler/Patterns.hs
index a354ccf3..e2b18223 100644
--- a/src/LambdaCube/Compiler/Patterns.hs
+++ b/src/LambdaCube/Compiler/Patterns.hs
@@ -3,6 +3,7 @@
 -- overview:
 -- https://rawgit.com/BP-HUG/presentations/master/2016_april/pattern-match-compilation/patternMatchComp.html
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -292,11 +293,20 @@ type GuardTrees = Lets GuardTree
 
 instance Monoid GuardTrees where
     mempty = In GTFailure
+#if !MIN_VERSION_base(4,11,0)
     LLet sn e x `mappend` y = LLet sn e $ x `mappend` rUp 1 0 y
     LTypeAnn t x `mappend` y = LTypeAnn t $ x `mappend` y
     In (GuardNode e n ps t ts) `mappend` y = In $ GuardNode e n ps t (ts `mappend` y)
     In GTFailure `mappend` y = y
     x@(In GTSuccess{}) `mappend` _ = x
+#else
+instance Semigroup GuardTrees where
+    LLet sn e x <> y = LLet sn e $ x <> rUp 1 0 y
+    LTypeAnn t x <> y = LTypeAnn t $ x <> y
+    In (GuardNode e n ps t ts) <> y = In $ GuardNode e n ps t (ts <> y)
+    In GTFailure <> y = y
+    x@(In GTSuccess{}) <> _ = x
+#endif
 
 noGuards :: SExp -> GuardTrees
 noGuards = In . GTSuccess
diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs
index 24e540dd..2f333e85 100644
--- a/src/LambdaCube/Compiler/Pretty.hs
+++ b/src/LambdaCube/Compiler/Pretty.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
@@ -101,7 +102,12 @@ pattern DText s = DAtom (SimpleAtom s)
 
 instance Monoid Doc where
     mempty = text ""
+#if !MIN_VERSION_base(4,11,0)
     mappend = dTwo mappend
+#else
+instance Semigroup Doc where
+    (<>)    = dTwo (<>)
+#endif
 
 instance Show Doc where
     show = ($ "") . P.displayS . P.renderPretty 0.4 200 . renderDoc