diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -36,3 +36,13 @@ derives from several sources, all of which are distributable under BSD-style or compatible licenses. See the file LICENSE for the complete license text. + + +Maintenance +-------------- + +Dan Burton is currently keeping haskell-src-exts on life support. +If you are interested in more actively making improvements to this package, +please make your interests known. + +You might want to try [ghc-lib-parser](http://hackage.haskell.org/package/ghc-lib-parser) instead. diff --git a/haskell-src-exts.cabal b/haskell-src-exts.cabal --- a/haskell-src-exts.cabal +++ b/haskell-src-exts.cabal @@ -1,10 +1,10 @@ Name: haskell-src-exts -Version: 1.21.0 +Version: 1.21.1 License: BSD3 License-File: LICENSE Build-Type: Simple Author: Niklas Broberg -Maintainer: Matthew Pickering +Maintainer: Dan Burton Category: Language Synopsis: Manipulating Haskell source: abstract syntax, lexer, parser, and pretty-printer Description: Haskell-Source with Extensions (HSE, haskell-src-exts) @@ -15,16 +15,17 @@ it also handles regular patterns as per the HaRP extension as well as HSX-style embedded XML syntax. Homepage: https://github.com/haskell-suite/haskell-src-exts +Bug-Reports: https://github.com/haskell-suite/haskell-src-exts/issues Stability: Stable Cabal-Version: >= 1.10 Tested-With: - GHC == 7.6.3 - , GHC == 7.8.2 + GHC == 7.8.2 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.1 - , GHC == 8.6.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.1 Extra-Source-Files: README.md diff --git a/src/Language/Haskell/Exts/ExactPrint.hs b/src/Language/Haskell/Exts/ExactPrint.hs --- a/src/Language/Haskell/Exts/ExactPrint.hs +++ b/src/Language/Haskell/Exts/ExactPrint.hs @@ -25,6 +25,7 @@ import Language.Haskell.Exts.Comments import Control.Monad (when, liftM, ap, unless) +import qualified Control.Monad.Fail as Fail #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif @@ -57,6 +58,9 @@ EP f = k a (b, l2, c2, s2) = f l1 c1 in (b, l2, c2, s1 . s2) + +instance Fail.MonadFail EP where + fail = error runEP :: EP () -> [Comment] -> String runEP (EP f) cs = let (_,_,_,s) = f (1,1) cs in s "" diff --git a/src/Language/Haskell/Exts/Fixity.hs b/src/Language/Haskell/Exts/Fixity.hs --- a/src/Language/Haskell/Exts/Fixity.hs +++ b/src/Language/Haskell/Exts/Fixity.hs @@ -39,6 +39,7 @@ import Language.Haskell.Exts.SrcLoc import Control.Monad (when, (<=<), liftM, liftM2, liftM3, liftM4) +import qualified Control.Monad.Fail as Fail import Data.Traversable (mapM) import Data.Maybe (fromMaybe) import Data.Typeable @@ -59,9 +60,9 @@ -- | Tweak any expressions in the element to account for the -- fixities given. Assumes that all operator expressions are -- fully left associative chains to begin with. - applyFixities :: Monad m => [Fixity] -- ^ The fixities to account for. - -> ast SrcSpanInfo -- ^ The element to tweak. - -> m (ast SrcSpanInfo) -- ^ The same element, but with operator expressions updated, or a failure. + applyFixities :: Fail.MonadFail m => [Fixity] -- ^ The fixities to account for. + -> ast SrcSpanInfo -- ^ The element to tweak. + -> m (ast SrcSpanInfo) -- ^ The same element, but with operator expressions updated, or a failure. assocNone, assocLeft, assocRight :: Assoc () assocNone = AssocNone () @@ -241,7 +242,7 @@ _ -> return dir where fix x = applyFixities fixs x -appFixDecls :: Monad m => Maybe (ModuleName SrcSpanInfo) -> [Fixity] -> [Decl SrcSpanInfo] -> m [Decl SrcSpanInfo] +appFixDecls :: Fail.MonadFail m => Maybe (ModuleName SrcSpanInfo) -> [Fixity] -> [Decl SrcSpanInfo] -> m [Decl SrcSpanInfo] appFixDecls mmdl fixs decls = let extraFixs = getFixities mmdl decls in mapM (applyFixities (fixs++extraFixs)) decls @@ -379,7 +380,7 @@ -- Recursively fixes the "leaves" of the infix chains, -- without yet touching the chain itself. We assume all chains are -- left-associate to begin with. -leafFix :: Monad m => [Fixity] -> Exp SrcSpanInfo -> m (Exp SrcSpanInfo) +leafFix :: Fail.MonadFail m => [Fixity] -> Exp SrcSpanInfo -> m (Exp SrcSpanInfo) leafFix fixs e' = case e' of InfixApp l e1 op e2 -> liftM2 (flip (InfixApp l) op) (leafFix fixs e1) (fix e2) App l e1 e2 -> liftM2 (App l) (fix e1) (fix e2) @@ -427,7 +428,7 @@ where fix x = applyFixities fixs x -leafFixP :: Monad m => [Fixity] -> Pat SrcSpanInfo -> m (Pat SrcSpanInfo) +leafFixP :: Fail.MonadFail m => [Fixity] -> Pat SrcSpanInfo -> m (Pat SrcSpanInfo) leafFixP fixs p' = case p' of PInfixApp l p1 op p2 -> liftM2 (flip (PInfixApp l) op) (leafFixP fixs p1) (fix p2) PApp l n ps -> liftM (PApp l n) $ mapM fix ps diff --git a/src/Language/Haskell/Exts/ParseMonad.hs b/src/Language/Haskell/Exts/ParseMonad.hs --- a/src/Language/Haskell/Exts/ParseMonad.hs +++ b/src/Language/Haskell/Exts/ParseMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -96,7 +97,9 @@ instance Monad ParseResult where return = ParseOk +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif ParseOk x >>= f = f x ParseFailed loc msg >>= _ = ParseFailed loc msg instance Fail.MonadFail ParseResult where @@ -246,7 +249,9 @@ case m i x y l ch s mode of Failed loc msg -> Failed loc msg Ok s' a -> runP (k a) i x y l ch s' mode +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail P where fail s = P $ \_r _col _line loc _ _stk _m -> Failed loc s @@ -354,7 +359,9 @@ return a = Lex $ \k -> k a Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) Lex v >> Lex w = Lex $ \k -> v (\_ -> w k) +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail (Lex r) where fail s = Lex $ \_ -> fail s diff --git a/tests/examples/t402.hs b/tests/examples/t402.hs deleted file mode 100644 --- a/tests/examples/t402.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeInType #-} -module Test where - -import Data.Singletons.Prelude -import Data.Singletons.TypeLits -import Data.Type.Equality ((:~:) (..), (:~~:) (..)) - -data instance Sing (z :: (a :~: b)) where - SRefl :: Sing Refl diff --git a/tests/examples/t402.hs.exactprinter.golden b/tests/examples/t402.hs.exactprinter.golden deleted file mode 100644 --- a/tests/examples/t402.hs.exactprinter.golden +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeInType #-} -module Test where - -import Data.Singletons.Prelude -import Data.Singletons.TypeLits -import Data.Type.Equality ((:~:) (..), (:~~:) (..)) - -data instance Sing (z :: (a :~: b)) where - SRefl :: Sing Refl - diff --git a/tests/examples/t402.hs.parser.golden b/tests/examples/t402.hs.parser.golden deleted file mode 100644 --- a/tests/examples/t402.hs.parser.golden +++ /dev/null @@ -1,388 +0,0 @@ -ParseOk - ( Module - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 1 1 14 1 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 1 1 1 1 - , SrcSpan "tests/examples/t402.hs" 2 1 2 1 - , SrcSpan "tests/examples/t402.hs" 3 1 3 1 - , SrcSpan "tests/examples/t402.hs" 4 1 4 1 - , SrcSpan "tests/examples/t402.hs" 5 1 5 1 - , SrcSpan "tests/examples/t402.hs" 6 1 6 1 - , SrcSpan "tests/examples/t402.hs" 6 1 6 1 - , SrcSpan "tests/examples/t402.hs" 8 1 8 1 - , SrcSpan "tests/examples/t402.hs" 9 1 9 1 - , SrcSpan "tests/examples/t402.hs" 10 1 10 1 - , SrcSpan "tests/examples/t402.hs" 12 1 12 1 - , SrcSpan "tests/examples/t402.hs" 14 1 14 1 - , SrcSpan "tests/examples/t402.hs" 14 1 14 1 - ] - } - (Just - (ModuleHead - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 6 1 6 18 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 6 1 6 7 - , SrcSpan "tests/examples/t402.hs" 6 13 6 18 - ] - } - (ModuleName - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 6 8 6 12 - , srcInfoPoints = [] - } - "Test") - Nothing - Nothing)) - [ LanguagePragma - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 1 1 1 30 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 1 1 1 13 - , SrcSpan "tests/examples/t402.hs" 1 27 1 30 - ] - } - [ Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 1 14 1 26 - , srcInfoPoints = [] - } - "TypeFamilies" - ] - , LanguagePragma - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 2 1 2 40 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 2 1 2 13 - , SrcSpan "tests/examples/t402.hs" 2 37 2 40 - ] - } - [ Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 2 14 2 19 - , srcInfoPoints = [] - } - "GADTs" - ] - , LanguagePragma - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 3 1 3 31 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 3 1 3 13 - , SrcSpan "tests/examples/t402.hs" 3 28 3 31 - ] - } - [ Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 3 14 3 27 - , srcInfoPoints = [] - } - "TypeOperators" - ] - , LanguagePragma - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 4 1 4 27 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 4 1 4 13 - , SrcSpan "tests/examples/t402.hs" 4 24 4 27 - ] - } - [ Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 4 14 4 23 - , srcInfoPoints = [] - } - "DataKinds" - ] - , LanguagePragma - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 5 1 5 28 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 5 1 5 13 - , SrcSpan "tests/examples/t402.hs" 5 25 5 28 - ] - } - [ Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 5 14 5 24 - , srcInfoPoints = [] - } - "TypeInType" - ] - ] - [ ImportDecl - { importAnn = - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 8 1 8 41 - , srcInfoPoints = [ SrcSpan "tests/examples/t402.hs" 8 1 8 7 ] - } - , importModule = - ModuleName - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 8 18 8 41 - , srcInfoPoints = [] - } - "Data.Singletons.Prelude" - , importQualified = False - , importSrc = False - , importSafe = False - , importPkg = Nothing - , importAs = Nothing - , importSpecs = Nothing - } - , ImportDecl - { importAnn = - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 9 1 9 42 - , srcInfoPoints = [ SrcSpan "tests/examples/t402.hs" 9 1 9 7 ] - } - , importModule = - ModuleName - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 9 18 9 42 - , srcInfoPoints = [] - } - "Data.Singletons.TypeLits" - , importQualified = False - , importSrc = False - , importSafe = False - , importPkg = Nothing - , importAs = Nothing - , importSpecs = Nothing - } - , ImportDecl - { importAnn = - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 1 10 73 - , srcInfoPoints = [ SrcSpan "tests/examples/t402.hs" 10 1 10 7 ] - } - , importModule = - ModuleName - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 18 10 36 - , srcInfoPoints = [] - } - "Data.Type.Equality" - , importQualified = False - , importSrc = False - , importSafe = False - , importPkg = Nothing - , importAs = Nothing - , importSpecs = - Just - (ImportSpecList - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 48 10 73 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 10 48 10 49 - , SrcSpan "tests/examples/t402.hs" 10 59 10 60 - , SrcSpan "tests/examples/t402.hs" 10 72 10 73 - ] - } - False - [ IThingAll - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 49 10 59 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 10 55 10 56 - , SrcSpan "tests/examples/t402.hs" 10 56 10 58 - , SrcSpan "tests/examples/t402.hs" 10 58 10 59 - ] - } - (Symbol - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 49 10 54 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 10 49 10 50 - , SrcSpan "tests/examples/t402.hs" 10 50 10 53 - , SrcSpan "tests/examples/t402.hs" 10 53 10 54 - ] - } - ":~:") - , IThingAll - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 61 10 72 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 10 68 10 69 - , SrcSpan "tests/examples/t402.hs" 10 69 10 71 - , SrcSpan "tests/examples/t402.hs" 10 71 10 72 - ] - } - (Symbol - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 10 61 10 67 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 10 61 10 62 - , SrcSpan "tests/examples/t402.hs" 10 62 10 66 - , SrcSpan "tests/examples/t402.hs" 10 66 10 67 - ] - } - ":~~:") - ]) - } - ] - [ GDataInsDecl - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 1 14 0 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 12 6 12 14 - , SrcSpan "tests/examples/t402.hs" 12 37 12 42 - , SrcSpan "tests/examples/t402.hs" 13 9 13 9 - , SrcSpan "tests/examples/t402.hs" 14 1 14 0 - ] - } - (DataType - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 1 12 5 - , srcInfoPoints = [] - }) - (TyApp - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 15 12 36 - , srcInfoPoints = [] - } - (TyCon - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 15 12 19 - , srcInfoPoints = [] - } - (UnQual - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 15 12 19 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 15 12 19 - , srcInfoPoints = [] - } - "Sing"))) - (TyKind - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 20 12 36 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 12 20 12 21 - , SrcSpan "tests/examples/t402.hs" 12 23 12 25 - , SrcSpan "tests/examples/t402.hs" 12 35 12 36 - ] - } - (TyVar - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 21 12 22 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 21 12 22 - , srcInfoPoints = [] - } - "z")) - (TyParen - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 26 12 35 - , srcInfoPoints = - [ SrcSpan "tests/examples/t402.hs" 12 26 12 27 - , SrcSpan "tests/examples/t402.hs" 12 34 12 35 - ] - } - (TyInfix - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 27 12 34 - , srcInfoPoints = [] - } - (TyVar - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 27 12 28 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 27 12 28 - , srcInfoPoints = [] - } - "a")) - (UnpromotedName - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 29 12 32 - , srcInfoPoints = [] - } - (UnQual - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 29 12 32 - , srcInfoPoints = [] - } - (Symbol - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 29 12 32 - , srcInfoPoints = [] - } - ":~:"))) - (TyVar - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 33 12 34 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 12 33 12 34 - , srcInfoPoints = [] - } - "b")))))) - Nothing - [ GadtDecl - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 9 13 27 - , srcInfoPoints = [ SrcSpan "tests/examples/t402.hs" 13 15 13 17 ] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 9 13 14 - , srcInfoPoints = [] - } - "SRefl") - Nothing - Nothing - Nothing - (TyApp - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 18 13 27 - , srcInfoPoints = [] - } - (TyCon - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 18 13 22 - , srcInfoPoints = [] - } - (UnQual - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 18 13 22 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 18 13 22 - , srcInfoPoints = [] - } - "Sing"))) - (TyCon - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 23 13 27 - , srcInfoPoints = [] - } - (UnQual - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 23 13 27 - , srcInfoPoints = [] - } - (Ident - SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/t402.hs" 13 23 13 27 - , srcInfoPoints = [] - } - "Refl")))) - ] - [] - ] - , [] - ) diff --git a/tests/examples/t402.hs.prettyparser.golden b/tests/examples/t402.hs.prettyparser.golden deleted file mode 100644 --- a/tests/examples/t402.hs.prettyparser.golden +++ /dev/null @@ -1,1 +0,0 @@ -Match diff --git a/tests/examples/t402.hs.prettyprinter.golden b/tests/examples/t402.hs.prettyprinter.golden deleted file mode 100644 --- a/tests/examples/t402.hs.prettyprinter.golden +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeInType #-} -module Test where -import Data.Singletons.Prelude -import Data.Singletons.TypeLits -import Data.Type.Equality ((:~:)(..), (:~~:)(..)) - -data instance Sing (z :: (a :~: b)) where - SRefl :: Sing Refl