use megaparsec 5.0

5 files changed, 40 insertions, 20 deletions

diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal
index c0de68a1..0eb3868c 100644
--- a/lambdacube-compiler.cabal
+++ b/lambdacube-compiler.cabal
@@ -83,7 +83,7 @@ library
     exceptions >= 0.8 && <0.9,
     filepath >=1.4 && <1.5,
     mtl >=2.2 && <2.3,
-    megaparsec >= 4.4.0 && <4.5,
+    megaparsec >=5.0 && <5.1,
     ansi-wl-pprint >=0.6 && <0.7,
     pretty-show >= 1.6.9,
     text >= 1.2 && <1.3,
@@ -107,7 +107,7 @@ executable lambdacube-compiler-unit-tests
     base < 4.10,
     containers >=0.5 && <0.6,
     lambdacube-compiler,
-    megaparsec >= 4.3.0 && <4.5,
+    megaparsec >=5.0 && <5.1,
     QuickCheck >= 2.8.2 && <2.10,
     tasty >= 0.11 && <0.12,
     tasty-quickcheck >=0.8 && <0.9
@@ -136,7 +136,7 @@ executable lambdacube-compiler-test-suite
     mtl >=2.2 && <2.3,
     monad-control >= 1.0 && <1.1,
     optparse-applicative >=0.12 && <0.14,
-    megaparsec >= 4.3.0 && <4.5,
+    megaparsec >=5.0 && <5.1,
     ansi-wl-pprint >=0.6 && <0.7,
     patience >= 0.1 && < 0.2,
     text >= 1.2 && <1.3,
@@ -244,7 +244,7 @@ executable lambdacube-compiler-coverage-test-suite
     mtl >=2.2 && <2.3,
     monad-control >= 1.0 && <1.1,
     optparse-applicative >=0.12 && <0.14,
-    megaparsec >= 4.3.0 && <4.5,
+    megaparsec >=5.0 && <5.1,
     ansi-wl-pprint >=0.6 && <0.7,
     pretty-show >= 1.6.9,
     patience >= 0.1 && < 0.2,
diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs
index 2b7f8cda..66179853 100644
--- a/src/LambdaCube/Compiler/Lexer.hs
+++ b/src/LambdaCube/Compiler/Lexer.hs
@@ -6,22 +6,25 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
 module LambdaCube.Compiler.Lexer
     ( module LambdaCube.Compiler.Lexer
     , module ParseUtils
     ) where
 
 import Data.List
+import Data.List.NonEmpty (fromList)
 import Data.Char
 import qualified Data.Set as Set
 import Control.Monad.Except
 import Control.Monad.RWS
 import Control.Applicative
+import Control.Arrow
 
-import Text.Megaparsec hiding (State)
+import Text.Megaparsec hiding (State, ParseError)
 import qualified Text.Megaparsec as P
-import Text.Megaparsec as ParseUtils hiding (try, Message, State)
+import Text.Megaparsec as ParseUtils hiding (try, Message, State, ParseError)
 import Text.Megaparsec.Lexer hiding (lexeme, symbol, negate)
 
 import LambdaCube.Compiler.Pretty hiding (parens)
@@ -34,19 +37,21 @@ import LambdaCube.Compiler.DesugaredSource
 try_ s m = try m <?> s
 
 toSPos :: SourcePos -> SPos
-toSPos p = SPos (sourceLine p) (sourceColumn p)
+toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p)
 
 getSPos = toSPos <$> getPosition
 
 -------------------------------------------------------------------------------- literals
 
-parseLit :: Parse r w Lit
+parseLit :: forall r w . Parse r w Lit
 parseLit = lexeme (LChar <$> charLiteral <|> LString <$> stringLiteral <|> natFloat) <?> "literal"
   where
+    charLiteral :: Parse r w Char
     charLiteral = between (char '\'')
                           (char '\'' <?> "end of character")
                           (char '\\' *> escapeCode <|> satisfy ((&&) <$> (> '\026') <*> (/= '\'')) <?> "character")
 
+    stringLiteral :: Parse r w String
     stringLiteral = between (char '"')
                             (char '"' <?> "end of string")
                             (concat <$> many stringChar)
@@ -57,6 +62,7 @@ parseLit = lexeme (LChar <$> charLiteral <|> LString <$> stringLiteral <|> natFl
                    <|> [] <$ char '&'
                    <|> (:[]) <$> escapeCode
 
+    escapeCode :: Parse r w Char
     escapeCode = choice (charEsc ++ charNum: (char '^' *> charControl): charAscii) <?> "escape code"
       where
         charControl = toEnum . (+ (-64)) . fromEnum <$> satisfy ((&&) <$> (>= 'A') <*> (<= '_')) <?> "control char"
@@ -73,6 +79,7 @@ parseLit = lexeme (LChar <$> charLiteral <|> LString <$> stringLiteral <|> natFl
             --                               \a  \b \t \n \v \f \r                                                                  ' '
             y = toEnum <$> ([0..32] ++ [127])
 
+    natFloat :: Parse r w Lit
     natFloat = char '0' *> zeroNumFloat <|> decimalFloat
       where
         zeroNumFloat = LInt <$> (oneOf "xX" *> hexadecimal <|> oneOf "oO" *> octal)
@@ -105,13 +112,18 @@ 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 (filePath fi) (fileContent fi))
+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))
 
 --type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String)))
-type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec String)
+type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec Dec String)
+
+newtype ParseError = ParseErr (P.ParseError (Token String) Dec)
+
+instance Show ParseError where
+    show (ParseErr e) = parseErrorPretty e
 
 runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w])
-runParse p (env, st) = snd . flip runParser' st $ evalRWST p env (error "spos")
+runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos")
 
 getParseState :: Parse r w (ParseState r)
 getParseState = (,) <$> ask <*> getParserState
@@ -154,6 +166,7 @@ noSpaceBefore p = try $ do
 
 lexeme_ p = lexemeWithoutSpace p <* whiteSpace
 
+lexeme :: Parse r w a -> Parse r w a
 lexeme p = snd <$> lexeme_ p
 
 lexemeName p = uncurry SIName <$> lexeme_ p
@@ -214,6 +227,7 @@ opLetter          = lowercaseOpLetter <|> char ':'
 
 maybeStartWith p i = i <|> (:) <$> satisfy p <*> i
 
+upperCase, upperCase_, lowerCase :: Parse r w SIName
 upperCase       = identifier (tick =<< (:) <$> upperLetter <*> many identLetter) <?> "uppercase ident"
 upperCase_      = identifier (tick =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident"
 lowerCase       = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident"
@@ -237,10 +251,13 @@ reservedOp name = fst <$> lexeme_ (try $ string name *> notFollowedBy opLetter)
 
 reserved name = fst <$> lexeme_ (try $ string name *> notFollowedBy identLetter)
 
-expect msg p i = i >>= \n -> if p n then unexpected (msg ++ " " ++ show n) else return n
+expect :: String -> (String -> Bool) -> Parse r w String -> Parse r w String
+expect msg p i = i >>= \n -> if p n then unexpected (Tokens $ fromList n) else return n
 
+identifier :: Parse r w String -> Parse r w SIName
 identifier name = lexemeName $ try $ expect "reserved word" (`Set.member` theReservedNames) name
 
+operator :: Parse r w String -> Parse r w SIName
 operator name = lexemeName $ try $ expect "reserved operator" (`Set.member` theReservedOpNames) name
 
 theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"]
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index db059fcb..8db4b855 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module LambdaCube.Compiler.Parser
     ( parseLC
     , runDefParser
diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs
index 5ec3815c..2834497b 100644
--- a/src/LambdaCube/Compiler/Utils.hs
+++ b/src/LambdaCube/Compiler/Utils.hs
@@ -115,8 +115,9 @@ instance MonadMask m => MonadMask (ExceptT e m) where
     mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
     uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
 -}
-instance (Monoid w, P.MonadParsec st m t) => P.MonadParsec st (RWST r w s m) t where
-    failure                     = lift . P.failure
+
+instance (Monoid w, P.MonadParsec e s m) => P.MonadParsec e s (RWST r w st m) where
+    failure a b                 = lift . P.failure a b
     label                       = mapRWST . P.label
     try                         = mapRWST P.try
     lookAhead          (RWST m) = RWST $ \r s -> (\(a, _, _) -> (a, s, mempty)) <$> P.lookAhead (m r s)
@@ -124,8 +125,7 @@ instance (Monoid w, P.MonadParsec st m t) => P.MonadParsec st (RWST r w s m) t w
     withRecovery rec   (RWST m) = RWST $ \r s -> P.withRecovery (\e -> runRWST (rec e) r s) (m r s)
     eof                         = lift P.eof
     token  f e                  = lift $ P.token  f e
-    tokens f e ts               = lift $ P.tokens f e ts
+    tokens f e                  = lift $ P.tokens f e
     getParserState              = lift P.getParserState
     updateParserState f         = lift $ P.updateParserState f
 
-
diff --git a/test/UnitTests.hs b/test/UnitTests.hs
index 56b7f3b1..52569f48 100644
--- a/test/UnitTests.hs
+++ b/test/UnitTests.hs
@@ -2,7 +2,7 @@
 module Main where
 
 import Data.Monoid
-import Text.Megaparsec.Pos (SourcePos(..), newPos, sourceName, sourceLine, sourceColumn)
+import Text.Megaparsec.Pos (Pos, unsafePos, SourcePos(..), sourceName, sourceLine, sourceColumn)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -28,12 +28,14 @@ main = defaultMain $ testGroup "Compiler"
 ----------------------------------------------------------------- Arbitraries
 
 -- SourcePos
+instance Arbitrary Pos where
+    arbitrary = unsafePos . getPositive <$> arbitrary
 
 instance Arbitrary SourcePos where
-  arbitrary = newPos <$> arbitrary <*> (getPositive <$> arbitrary) <*> (getPositive <$> arbitrary)
+  arbitrary = SourcePos <$> arbitrary <*> arbitrary <*> arbitrary
   shrink pos
     | n <- sourceName pos, l <- sourceLine pos, c <- sourceColumn pos
-      = [newPos n' l' c' | n' <- shrink n, l' <- shrink l, c' <- shrink c]
+      = [SourcePos n' l' c' | n' <- shrink n, l' <- shrink l, c' <- shrink c]
   -- TODO: Diagonalize shrink
 
 -- TODO: generate only valid positions