Megaparsec 7 Compatibility Fix

.gitignore

@@ -10,3 +10,4 @@ lambdacube-compiler-test-suite.tix
 .ghc.environment.*
 .dir-locals.el
 .stack-work
+cabal.project

src/LambdaCube/Compiler/Lexer.hs

@@ -14,7 +14,7 @@ module LambdaCube.Compiler.Lexer
     ) where
 
 import Data.List
-import Data.List.NonEmpty (fromList)
+import Data.List.NonEmpty (NonEmpty, fromList)
 import Data.Char
 import qualified Data.Set as Set
 import Data.Void
@@ -34,6 +34,7 @@ import LambdaCube.Compiler.DesugaredSource
 
 -------------------------------------------------------------------------------- utils
 
+
 -- try with error handling
 -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602
 try_ :: String -> Parse r w a -> Parse r w a
@@ -43,7 +44,7 @@ toSPos :: SourcePos -> SPos
 toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p)
 
 getSPos :: Parse r w SPos
-getSPos = toSPos <$> getPosition
+getSPos = toSPos <$> getSourcePos
 
 -------------------------------------------------------------------------------- literals
 
@@ -113,21 +114,26 @@ data ParseEnv r = ParseEnv
     , indentationLevel :: SPos
     }
 
-type ParseState r = (ParseEnv r, P.State String)
+type ParseState r = (ParseEnv r, P.State String (ErrorFancy Void))
 
 parseState :: FileInfo -> r -> ParseState r
-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))
+parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec (ErrorFancy Void) String (P.State String (ErrorFancy Void))) (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 (ErrorFancy Void) String)
 
-newtype ParseError = ParseErr (P.ParseError (Token String) (ErrorFancy Void))
+newtype ParseError = ParseErr (P.ParseError String (ErrorFancy Void))
+
+instance (ShowErrorComponent v, Show v) => 
+  ShowErrorComponent (ErrorFancy v) where
+  showErrorComponent (ErrorCustom e) = showErrorComponent e
+  showErrorComponent x = show x
 
 instance Show ParseError where
     show (ParseErr e) = parseErrorPretty e
 
-runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w])
-runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos")
+runParse :: Parse r w a -> ParseState r -> Either (NonEmpty ParseError) (a, [w])
+runParse p (env, st) = left (fmap ParseErr . bundleErrors) . snd . flip runParser' st $ evalRWST p env (error "spos")
 
 getParseState :: Parse r w (ParseState r)
 getParseState = (,) <$> ask <*> getParserState

src/LambdaCube/Compiler/Parser.hs

@@ -20,6 +20,7 @@ module LambdaCube.Compiler.Parser
 import Data.Monoid
 import Data.Maybe
 import Data.List
+import Data.List.NonEmpty (NonEmpty, fromList)
 import Data.Char
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -53,7 +54,7 @@ data LCParseError
     = MultiplePatternVars [[SIName]]
     | OperatorMismatch SIName SIName
     | UndefinedConstructor SIName
-    | ParseError ParseError
+    | ParseError (NonEmpty ParseError)
 
 data ParseWarning
     = Unreachable Range
@@ -621,7 +622,7 @@ parseExtensions
 
 type Module = Module_ DefParser
 
-type DefParser = DesugarInfo -> Either ParseError ([Stmt], [PostponedCheck])
+type DefParser = DesugarInfo -> Either (NonEmpty ParseError) ([Stmt], [PostponedCheck])
 
 type HeaderParser = Parse () ()
 
@@ -655,15 +656,15 @@ parseModule = do
         , definitions   = \ge -> runParse (parseDefs SLHS <* eof) (env { desugarInfo = ge }, st)
         }
 
-parseLC :: FileInfo -> Either ParseError Module
+parseLC :: FileInfo -> Either (NonEmpty ParseError) Module
 parseLC fi
     = fmap fst $ runParse parseModule $ parseState fi ()
 
 runDefParser :: (MonadFix m, MonadError LCParseError m) => DesugarInfo -> DefParser -> m ([Stmt], [ParseWarning], DesugarInfo)
 runDefParser ds_ dp = do
 
     (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do
-        let x :: Either ParseError ([Stmt], [PostponedCheck])
+        let x :: Either (NonEmpty ParseError) ([Stmt], [PostponedCheck])
             x = dp (ds <> ds_)
         (defs, dns) <- either (throwError . ParseError) return x
         return (defs, dns, mkDesugarInfo defs)