ghc-lib-parser-ex 0.20200401 → 0.20200501

raw patch · 11 files changed

+197/−46 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• ghc-lib-parser-ex.cabal +1/−1
• src/Language/Haskell/GhclibParserEx/Config.hs +6/−2
• src/Language/Haskell/GhclibParserEx/Fixity.hs +22/−3
• src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs +18/−0
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs +31/−2
• src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs +9/−2
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs +44/−7
• src/Language/Haskell/GhclibParserEx/Outputable.hs +9/−2
• src/Language/Haskell/GhclibParserEx/Parse.hs +28/−4
• test/Test.hs +19/−23

@@ -1,5 +1,15 @@ # Changelog for ghc-lib-parser-ex +## 0.20200501 released 2020-05-01++## 8.10.0.4 released 2020-04-04+- Add expression predicates `isWholeFrac`, `isFieldPunUpdate`, `isStrictMatch`, `isMultiIf`, `isProc`, `isTransStmt`;+- Add pattern predicate `isPFieldPun`.++## 8.10.0.3 released 2020-04-03+- `strToPat` now returns an `LPat GhcPs`+- `parseExpression` now returns an `ParseResult (LHsExpr GhcPs)` (>= ghc-8.10)+ ## 0.20200401 released 2020-04-01  ## 8.10.0.2 released 2020-03-30

@@ -1,6 +1,6 @@ cabal-version: >= 1.18 name:           ghc-lib-parser-ex-version:        0.20200401+version:        0.20200501 description:    Please see the README on GitHub at <https://github.com/shayne-fletcher/ghc-lib-parser-ex#readme> homepage:       https://github.com/shayne-fletcher/ghc-lib-parser-ex#readme bug-reports:    https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues

@@ -14,12 +14,16 @@ import Config #if defined (GHCLIB_API_811) import GHC.Driver.Session+import GHC.Utils.Fingerprint #else import DynFlags-#endif import Fingerprint+#endif -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+#if defined (GHCLIB_API_811)+import GHC.Platform+import GHC.Settings+#elif defined (GHCLIB_API_810) import GHC.Platform import ToolSettings #else

@@ -64,7 +64,10 @@ -- LPat and Pat have gone through a lot of churn. See -- https://gitlab.haskell.org/ghc/ghc/merge_requests/1925 for details. patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+#if defined (GHCLIB_API_811)+patFix fixities (L loc (ConPat _ op (InfixCon pat1 pat2))) =+  L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2)+#elif defined (GHCLIB_API_810) patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) =   L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #else@@ -78,22 +81,38 @@   -> Located RdrName -> Fixity   -> LPat GhcPs -> LPat GhcPs   -> Pat GhcPs-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+#if defined (GHCLIB_API_811)+mkConOpPat fs op2 fix2 p1@(L loc (ConPat _ op1 (InfixCon p11 p12))) p2+#elif defined (GHCLIB_API_810) mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #else mkConOpPat fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #endif+#if defined (GHCLIB_API_811)+  | nofix_error = ConPat noExtField op2 (InfixCon p1 p2)+#else   | nofix_error = ConPatIn op2 (InfixCon p1 p2)-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+#endif+#if defined (GHCLIB_API_811)+  | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2)))+#elif defined (GHCLIB_API_810)   | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #else   | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2))) #endif+#if defined (GHCLIB_API_811)+  | otherwise = ConPat noExtField op2 (InfixCon p1 p2)+#else   | otherwise = ConPatIn op2 (InfixCon p1 p2)+#endif   where     fix1 = findFixity' fs op1     (nofix_error, associate_right) = compareFixity fix1 fix2+#if defined (GHCLIB_API_811)+mkConOpPat _ op _ p1 p2 = ConPat noExtField op (InfixCon p1 p2)+#else mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2)+#endif  mkOpApp ::   [(String, Fixity)]

@@ -16,9 +16,21 @@   ) where  import qualified GHC.LanguageExtensions as LangExt+#if defined(GHCLIB_API_811)+import GHC.Utils.Panic+#else import Panic+#endif+#if defined(GHCLIB_API_811)+import GHC.Parser.Header+#else import HeaderInfo+#endif+#if defined(GHCLIB_API_811)+import GHC.Data.StringBuffer+#else import StringBuffer+#endif #if defined(GHCLIB_API_811) import GHC.Driver.Session import GHC.Driver.Types@@ -29,13 +41,19 @@ import GHC.LanguageExtensions.Type import Data.List import Data.Maybe+#if !defined(GHCLIB_API_811) import Data.Function+#endif import qualified Data.Map as Map +#if !defined(GHCLIB_API_811) -- Oprhan instance until -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 lands. instance Ord Extension where   compare = compare `on` fromEnum+#else+-- Update : It's landed.+#endif  -- | Parse a GHC extension. readExtension :: String -> Maybe Extension

@@ -10,8 +10,8 @@   isTag, isDol, isDot, isReturn, isSection, isRecConstr, isRecUpdate,   isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isLambda, isQuasiQuote,   isDotApp, isTypeApp, isWHNF, isLCase,-  isFieldPun, isRecStmt, isParComp, isMDo, isTupleSection, isString, isPrimLiteral,-  isSpliceDecl, isFieldWildcard, isUnboxed,+  isFieldPun, isFieldPunUpdate, isRecStmt, isParComp, isMDo, isTupleSection, isString, isPrimLiteral,+  isSpliceDecl, isFieldWildcard, isUnboxed, isWholeFrac, isStrictMatch, isMultiIf, isProc, isTransStmt,   hasFieldsDotDot,   varToStr, strToVar,   fromChar@@ -43,8 +43,14 @@ #else import BasicTypes #endif+#if defined (GHCLIB_API_811)+import GHC.Builtin.Types+#else import TysWiredIn+#endif +import Data.Ratio+ -- 'True' if the provided expression is a variable with name 'tag'. isTag :: String -> LHsExpr GhcPs -> Bool isTag tag = \case (L _ (HsVar _ (L _ s))) -> occNameString (rdrNameOcc s) == tag; _ -> False@@ -83,10 +89,19 @@   _ -> False isLCase = \case (L _ HsLamCase{}) -> True; _ -> False +isStrictMatch :: HsMatchContext RdrName -> Bool+isStrictMatch FunRhs{mc_strictness=SrcStrict} = True+isStrictMatch _ = False+ -- Field is punned e.g. '{foo}'. isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool isFieldPun = \case (L _ HsRecField {hsRecPun=True}) -> True; _ -> False +-- Field puns in updates have a different type to field puns in+-- constructions.+isFieldPunUpdate :: HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool+isFieldPunUpdate = \case HsRecField {hsRecPun=True} -> True; _ -> False+ -- Contains a '..' as in 'Foo{..}' hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool hasFieldsDotDot = \case HsRecFields {rec_dotdot=Just _} -> True; _ -> False@@ -121,6 +136,15 @@ isSpliceDecl :: HsExpr GhcPs -> Bool isSpliceDecl = \case HsSpliceE{} -> True; _ -> False +isMultiIf :: HsExpr GhcPs -> Bool+isMultiIf = \case HsMultiIf{} -> True; _ -> False++isProc :: HsExpr GhcPs -> Bool+isProc = \case HsProc{} -> True; _ -> False++isTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool+isTransStmt = \case TransStmt{} -> True; _ -> False+ -- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool isFieldWildcard = \case@@ -136,6 +160,11 @@  isUnboxed :: Boxity -> Bool isUnboxed = \case Unboxed -> True; _ -> False++isWholeFrac :: HsExpr GhcPs -> Bool+isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1+isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1+isWholeFrac _ = False  varToStr :: LHsExpr GhcPs -> String varToStr (L _ (HsVar _ (L _ n)))

@@ -2,6 +2,8 @@ -- SPDX-License-Identifier: BSD-3-Clause.  {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+#include "ghclib_api.h"  module Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances (     HsExtendInstances(..), extendInstances, astEq, astListEq)@@ -16,7 +18,12 @@ -- representations rather than the terms themselves, leads to -- identical results. +#if defined (GHCLIB_API_811)+import GHC.Utils.Outputable+#else import Outputable+#endif+ import Data.Data import Data.Function @@ -34,7 +41,7 @@ -- string representations. toStr :: Data a => HsExtendInstances a -> String toStr (HsExtendInstances e) =-  Outputable.showSDocUnsafe $ showAstData BlankSrcSpan e+  showSDocUnsafe $ showAstData BlankSrcSpan e  instance Data a => Eq (HsExtendInstances a) where (==) a b = toStr a == toStr b instance Data a => Ord (HsExtendInstances a) where compare = compare `on` toStr@@ -47,4 +54,4 @@  -- Use 'ppr' for 'Show'. instance Outputable a => Show (HsExtendInstances a) where-  show (HsExtendInstances e) =  Outputable.showSDocUnsafe $ Outputable.ppr e+  show (HsExtendInstances e) =  showSDocUnsafe $ ppr e

@@ -21,7 +21,11 @@ #else import SrcLoc #endif+#if defined (GHCLIB_API_811)+import GHC.Builtin.Types+#else import TysWiredIn+#endif #if defined (GHCLIB_API_811) import GHC.Types.Name.Reader import GHC.Types.Name@@ -29,10 +33,19 @@ import RdrName import OccName #endif+#if defined (GHCLIB_API_811)+import GHC.Data.FastString+#else import FastString+#endif  patToStr :: LPat GhcPs -> String-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+#if defined (GHCLIB_API_811)+patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True"+patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False"+patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]"+patToStr _ = ""+#elif defined (GHCLIB_API_810) patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]"@@ -44,14 +57,38 @@ patToStr _ = "" #endif -strToPat :: String -> Pat GhcPs+strToPat :: String -> LPat GhcPs strToPat z-  | z == "True"  = ConPatIn (noLoc true_RDR) (PrefixCon [])-  | z == "False" = ConPatIn (noLoc false_RDR) (PrefixCon [])-  | z == "[]"    = ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon [])+  | z == "True"  =+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+  noLoc $+#endif+#if defined (GHCLIB_API_811)+    ConPat noExtField (noLoc true_RDR) (PrefixCon [])+#else+    ConPatIn (noLoc true_RDR) (PrefixCon [])+#endif+  | z == "False" =+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+  noLoc $+#endif+#if defined (GHCLIB_API_811)+    ConPat noExtField (noLoc false_RDR) (PrefixCon [])+#else+    ConPatIn (noLoc false_RDR) (PrefixCon [])+#endif+  | z == "[]"    =+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+  noLoc $+#endif+#if defined (GHCLIB_API_811)+    ConPat noExtField (noLoc $ nameRdrName nilDataConName) (PrefixCon [])+#else+    ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon [])+#endif   | otherwise = #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-      VarPat noExtField (noLoc $ mkVarUnqual (fsLit z))+      noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit z)) #else       VarPat noExt (noLoc $ mkVarUnqual (fsLit z)) #endif@@ -89,7 +126,7 @@ #endif isPWildcard _ = False -isPFieldPun :: LHsRecField GhcPs (Pat GhcPs) -> Bool+isPFieldPun :: LHsRecField GhcPs (LPat GhcPs) -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) isPFieldPun (L _ HsRecField {hsRecPun=True}) = True #else

@@ -1,9 +1,16 @@ -- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. +{-# LANGUAGE CPP #-}+#include "ghclib_api.h"+ module Language.Haskell.GhclibParserEx.Outputable (unsafePrettyPrint) where +#if defined (GHCLIB_API_811)+import GHC.Utils.Outputable+#else import Outputable+#endif -unsafePrettyPrint :: (Outputable.Outputable a) => a -> String-unsafePrettyPrint = Outputable.showSDocUnsafe . Outputable.ppr+unsafePrettyPrint :: Outputable a => a -> String+unsafePrettyPrint = showSDocUnsafe . ppr

@@ -26,7 +26,11 @@  #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs+#if defined (GHCLIB_API_811)+import GHC.Parser.PostProcess+#else import RdrHsSyn+#endif #else import HsSyn #endif@@ -35,10 +39,27 @@ #else import DynFlags #endif+#if defined (GHCLIB_API_811)+import GHC.Data.StringBuffer+#else import StringBuffer+#endif+#if defined (GHCLIB_API_811)+import GHC.Parser.Lexer+import qualified GHC.Parser.Lexer as Lexer+#else import Lexer+#endif+#if defined (GHCLIB_API_811)+import qualified GHC.Parser as Parser+#else import qualified Parser+#endif+#if defined (GHCLIB_API_811)+import GHC.Data.FastString+#else import FastString+#endif #if defined (GHCLIB_API_811) import GHC.Types.SrcLoc #else@@ -50,7 +71,7 @@ import BkpSyn #endif #if defined (GHCLIB_API_811)-import UnitInfo+import GHC.Unit.Info #else import PackageConfig #endif@@ -94,12 +115,15 @@ parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) parseDeclaration = parse Parser.parseDeclaration +parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-parseExpression :: String -> DynFlags -> ParseResult RdrHsSyn.ECP+parseExpression s flags =+  case parse Parser.parseExpression s flags of+    POk s e -> unP (runECP_P e) s+    PFailed ps -> PFailed ps #else-parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)-#endif parseExpression = parse Parser.parseExpression+#endif  parsePattern :: String -> DynFlags -> ParseResult (LPat GhcPs) parsePattern = parse Parser.parsePattern

@@ -29,7 +29,6 @@  #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs-import RdrHsSyn #else import HsSyn #endif@@ -43,9 +42,21 @@ #else import DynFlags #endif+#if defined (GHCLIB_API_811)+import GHC.Parser.Lexer+#else import Lexer+#endif+#if defined (GHCLIB_API_811)+import GHC.Utils.Outputable+#else import Outputable+#endif+#if defined(GHCLIB_API_811)+import GHC.Utils.Error+#else import ErrUtils+#endif import GHC.LanguageExtensions.Type #if defined (GHCLIB_API_808) import Bag@@ -145,30 +156,13 @@ exprTest :: String -> DynFlags -> (LHsExpr GhcPs -> IO ()) -> IO () exprTest s flags test =       case parseExpression s flags of-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-        POk s e ->-#else-        POk _ e ->-#endif-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-          case unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs) of-            POk _  e ->-#endif-              test e-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-            _ -> assertFailure "parse error"-#endif+        POk _ e -> test e         _ -> assertFailure "parse error"  patTest :: String -> DynFlags -> (LPat GhcPs -> IO ()) -> IO () patTest s flags test =       case parsePattern s flags of-#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-        POk _ e ->-#else-        POk _ e ->-#endif-              test e+        POk _ e -> test e         _ -> assertFailure "parse error"  fixityTests :: TestTree@@ -269,6 +263,8 @@   , testCase "isSpliceDecl" $ test "$(a + b)" $ assert' . isSpliceDecl . unLoc   , testCase "isQuasiQuote" $ test "[expr|1 + 2|]" $ assert' . isQuasiQuote   , testCase "isQuasiQuote" $ test "[expr(1 + 2)]" $ assert' . not . isQuasiQuote+  , testCase "isWholeFrac" $ test "3.2e1" $ assert' . isWholeFrac . unLoc+  , testCase "isWholeFrac" $ test "3.22e1" $ assert' . not . isWholeFrac . unLoc   , testCase "strToVar" $ assert' . isVar . strToVar $ "foo"   , testCase "varToStr" $ test "[]" $ assert' . (== "[]") . varToStr   , testCase "varToStr" $ test "foo" $ assert' . (== "foo") . varToStr@@ -285,9 +281,9 @@   [ testCase "patToStr" $ test "True" $ assert' . (== "True") . patToStr   , testCase "patToStr" $ test "False" $ assert' . (== "False") . patToStr   , testCase "patToStr" $ test "[]" $ assert' . (== "[]") . patToStr-  , testCase "strToPat" $ assert' . (== "True") . patToStr . noLoc . strToPat $ "True"-  , testCase "strToPat" $ assert' . (== "False") . patToStr . noLoc . strToPat $ "False"-  , testCase "strToPat" $ assert' . (== "[]") . patToStr . noLoc . strToPat $ "[]"+  , testCase "strToPat" $ assert' . (== "True") . patToStr . strToPat $ "True"+  , testCase "strToPat" $ assert' . (== "False") . patToStr . strToPat $ "False"+  , testCase "strToPat" $ assert' . (== "[]") . patToStr . strToPat $ "[]"   , testCase "fromPChar" $ test "'a'" $ assert' . (== Just 'a') . fromPChar   , testCase "fromPChar" $ test "\"a\"" $ assert' . isNothing . fromPChar   ]