Semigroup-Monoid Proposal fixes: GHC 8.4 compat

4 files changed, 43 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