Merge pull request #13 from deepfire/master

Build with GHC 8.4.1

12 files changed, 100 insertions, 17 deletions

diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal
index a874e08e..09a96589 100644
--- a/lambdacube-compiler.cabal
+++ b/lambdacube-compiler.cabal
@@ -96,20 +96,20 @@ library
     binary,
     bytestring,
     time,
-    aeson >=1.1 && <1.2,
-    base >=4.9 && <5,
+    aeson >=1.1,
+    base >=4.9,
     semigroups,
-    containers >=0.5 && <0.6,
-    directory >=1.3 && <1.4,
-    exceptions >= 0.8 && <0.9,
-    filepath >=1.4 && <1.5,
-    mtl >=2.2 && <2.3,
-    megaparsec >=5.3 && <5.4,
-    ansi-wl-pprint >=0.6 && <0.7,
+    containers >=0.5,
+    directory >=1.3,
+    exceptions >= 0.8,
+    filepath >=1.4,
+    mtl >=2.2,
+    megaparsec >=5.3,
+    ansi-wl-pprint >=0.6,
     pretty-show >= 1.6.9,
-    text >= 1.2 && <1.3,
+    text >= 1.2,
     lambdacube-ir == 0.3.*,
-    vector >= 0.12 && <0.13
+    vector >= 0.12
 
   hs-source-dirs:      src
   default-language:    Haskell2010
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/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs
index ac7f7f71..c3f4e285 100644
--- a/src/LambdaCube/Compiler/Lexer.hs
+++ b/src/LambdaCube/Compiler/Lexer.hs
@@ -17,15 +17,17 @@ import Data.List
 import Data.List.NonEmpty (fromList)
 import Data.Char
 import qualified Data.Set as Set
+import Data.Void
 import Control.Monad.Except
 import Control.Monad.RWS
 import Control.Applicative
 import Control.Arrow
 
 import Text.Megaparsec hiding (State, ParseError)
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer hiding (lexeme, symbol)
 import qualified Text.Megaparsec as P
-import Text.Megaparsec as ParseUtils hiding (try, Message, State, ParseError)
-import Text.Megaparsec.Lexer hiding (lexeme, symbol, negate)
+import Text.Megaparsec as ParseUtils hiding (try, Message, State, ParseError, lexeme, symbol)
 
 import LambdaCube.Compiler.Pretty hiding (parens)
 import LambdaCube.Compiler.DesugaredSource
@@ -114,12 +116,12 @@ data ParseEnv r = ParseEnv
 type ParseState r = (ParseEnv r, P.State String)
 
 parseState :: FileInfo -> r -> ParseState r
-parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec Dec String (P.State String)) (filePath fi) (fileContent fi))
+parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec (ErrorFancy Void) String (P.State String)) (filePath fi) (fileContent fi))
 
 --type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String)))
-type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec Dec String)
+type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec (ErrorFancy Void) String)
 
-newtype ParseError = ParseErr (P.ParseError (Token String) Dec)
+newtype ParseError = ParseErr (P.ParseError (Token String) (ErrorFancy Void))
 
 instance Show ParseError where
     show (ParseErr e) = parseErrorPretty e
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 1ed8ac8c..752d7957 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 #-}
@@ -37,6 +38,8 @@ import LambdaCube.Compiler.DesugaredSource
 import LambdaCube.Compiler.Patterns
 import LambdaCube.Compiler.Statements
 
+import Text.Megaparsec.Char
+
 -------------------------------------------------------------------------------- parser type
 
 type BodyParser = Parse DesugarInfo PostponedCheck
@@ -124,7 +127,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
diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs
index 4e9eab27..42a63843 100644
--- a/src/LambdaCube/Compiler/Utils.hs
+++ b/src/LambdaCube/Compiler/Utils.hs
@@ -24,7 +24,6 @@ import Control.Monad.RWS
 import System.Directory
 import qualified Data.Text.IO as TIO
 import qualified Text.Megaparsec as P
-import qualified Text.Megaparsec.Prim as P
 
 ------------------------------------------------------- general functions