ghc-lib-parser-ex 8.8.5.2 → 8.8.5.3

raw patch · 8 files changed

+210/−12 lines, 8 filesdep ~extraPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: extra

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• ghc-lib-parser-ex.cabal +6/−2
• src/Language/Haskell/GhclibParserEx/DynFlags.hs +2/−1
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs +26/−0
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs +4/−5
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs +100/−0
• src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs +28/−0
• test/Test.hs +37/−3

@@ -2,8 +2,14 @@  ## Unreleased changes +## 8.8.5.3 released 2020-02-25+- New modules:+  - `Language.Haskell.GhclibParserEx.Pat`+  - `Language.Haskell.GhclibParserEx.Types`+  - `Language.Haskell.GhclibParserEx.Decls`+ ## 8.8.5.2 released 2020-02-16-- New `DynFlags` functions `readExtension, `extensionImplications`.+- New `DynFlags` functions `readExtension`, `extensionImplications`.  ## 8.8.5.1 released 2020-02-09 - Expression predicate tests.

@@ -1,6 +1,6 @@ cabal-version: >= 1.18 name:           ghc-lib-parser-ex-version:        8.8.5.2+version:        8.8.5.3 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@@ -34,6 +34,9 @@       Language.Haskell.GhclibParserEx.DynFlags       Language.Haskell.GhclibParserEx.Fixity       Language.Haskell.GhclibParserEx.GHC.Hs.Expr+      Language.Haskell.GhclibParserEx.GHC.Hs.Pat+      Language.Haskell.GhclibParserEx.GHC.Hs.Types+      Language.Haskell.GhclibParserEx.GHC.Hs.Decls       Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances       Language.Haskell.GhclibParserEx.Parse       Language.Haskell.GhclibParserEx.Outputable@@ -45,7 +48,8 @@       base >=4.7 && <5,       uniplate >= 1.5,       bytestring >= 0.10.8.2,-      containers >= 0.6.0.1+      containers >= 0.5.8.1,+      extra >= 1.6.19   if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)       build-depends:         ghc == 8.8.*,

@@ -22,13 +22,14 @@ import HscTypes import GHC.LanguageExtensions.Type import Data.List+import Data.List.Extra import Data.Maybe import qualified Data.Map as Map  -- | Parse a GHC extension. readExtension :: String -> Maybe Extension readExtension = (`Map.lookup` exts)-  where exts = Map.fromList [(show x, x) | x <- [minBound .. maxBound]]+  where exts = Map.fromList [(show x, x) | x <- enumerate]  -- | Implicitly enabled/disabled extensions. extensionImplications :: [(Extension, ([Extension], [Extension]))]

@@ -0,0 +1,26 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++{-# LANGUAGE CPP #-}+#include "ghclib_api.h"+module Language.Haskell.GhclibParserEx.GHC.Hs.Decls(+    isNewType, isForD, isDerivD, isClsDefSig+  ) where++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import SrcLoc++isNewType :: NewOrData -> Bool+isNewType NewType = True+isNewType DataType = False++isForD, isDerivD :: LHsDecl GhcPs -> Bool+isForD (L _ ForD{}) = True; isForD _ = False+isDerivD (L _ DerivD{}) = True; isDerivD _ = False++isClsDefSig :: Sig GhcPs -> Bool+isClsDefSig (ClassOpSig _ True _ _) = True; isClsDefSig _ = False

@@ -29,11 +29,6 @@ import BasicTypes import TysWiredIn -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)-noExt :: NoExtField-noExt = noExtField-#endif- -- '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@@ -133,7 +128,11 @@ varToStr _ = ""  strToVar :: String -> LHsExpr GhcPs+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+strToVar x = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc x))+#else strToVar x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x))+#endif  fromChar :: LHsExpr GhcPs -> Maybe Char fromChar = \case (L _ (HsLit _ (HsChar _ x))) -> Just x; _ -> Nothing

@@ -0,0 +1,100 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+#include "ghclib_api.h"+module Language.Haskell.GhclibParserEx.GHC.Hs.Pat(+    patToStr, strToPat+  , fromPChar+  , hasPFieldsDotDot+  , isPFieldWildcard, isPWildcard, isPFieldPun, isPatTypeSig, isPBangPat, isPViewPat+ ) where++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import SrcLoc+import TysWiredIn+import RdrName+import OccName+import FastString++patToStr :: LPat GhcPs -> String+#if defined (GHCLIB_API_811) || 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) == "[]" = "[]"+patToStr _ = ""+#else+patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True"+patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False"+patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]"+patToStr _ = ""+#endif++strToPat :: String -> Pat GhcPs+strToPat z+  | z == "True"  = ConPatIn (noLoc true_RDR) (PrefixCon [])+  | z == "False" = ConPatIn (noLoc false_RDR) (PrefixCon [])+  | z == "[]"    = ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon [])+  | otherwise =+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+      VarPat noExtField (noLoc $ mkVarUnqual (fsLit z))+#else+      VarPat noExt (noLoc $ mkVarUnqual (fsLit z))+#endif++fromPChar :: LPat GhcPs -> Maybe Char+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+fromPChar (L _ (LitPat _ (HsChar _ x))) = Just x+#else+fromPChar (dL -> L _ (LitPat _ (HsChar _ x))) = Just x+#endif+fromPChar _ = Nothing++-- Contains a '..' as in 'Foo{..}'+hasPFieldsDotDot :: HsRecFields GhcPs (Pat GhcPs) -> Bool+hasPFieldsDotDot HsRecFields {rec_dotdot=Just _} = True+hasPFieldsDotDot _ = False++-- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'.+isPFieldWildcard :: LHsRecField GhcPs (Pat GhcPs) -> Bool+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+isPFieldWildcard (L _ HsRecField {hsRecFieldArg=WildPat _}) = True+isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True+isPFieldWildcard (L _ HsRecField {}) = False+#else+isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=WildPat _}) = True+isPFieldWildcard (dL -> L _ HsRecField {hsRecPun=True}) = True+isPFieldWildcard (dL -> L _ HsRecField {}) = False+#endif++isPWildcard :: LPat GhcPs -> Bool+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+isPWildcard (L _ (WildPat _)) = True+#else+isPWildcard (dL -> L _ (WildPat _)) = True+#endif+isPWildcard _ = False++isPFieldPun :: LHsRecField GhcPs (Pat GhcPs) -> Bool+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+isPFieldPun (L _ HsRecField {hsRecPun=True}) = True+#else+isPFieldPun (dL -> L _ HsRecField {hsRecPun=True}) = True+#endif+isPFieldPun _ = False++isPatTypeSig, isPBangPat, isPViewPat :: LPat GhcPs -> Bool+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+isPatTypeSig (L _ SigPat{}) = True; isPatTypeSig _ = False+isPBangPat (L _ BangPat{}) = True; isPBangPat _ = False+isPViewPat (L _ ViewPat{}) = True; isPViewPat _ = False+#else+isPatTypeSig (dL -> L _ SigPat{}) = True; isPatTypeSig _ = False+isPBangPat (dL -> L _ BangPat{}) = True; isPBangPat _ = False+isPViewPat (dL -> L _ ViewPat{}) = True; isPViewPat _ = False+#endif

@@ -0,0 +1,28 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++{-# LANGUAGE CPP #-}+#include "ghclib_api.h"+module Language.Haskell.GhclibParserEx.GHC.Hs.Types(+    fromTyParen+  , isTyQuasiQuote, isUnboxedTuple+  ) where++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import SrcLoc++fromTyParen :: LHsType GhcPs -> LHsType GhcPs+fromTyParen (L _ (HsParTy _ x)) = x+fromTyParen x = x++isTyQuasiQuote :: LHsType GhcPs -> Bool+isTyQuasiQuote (L _ (HsSpliceTy _ HsQuasiQuote{})) = True+isTyQuasiQuote _ = False++isUnboxedTuple :: HsTupleSort -> Bool+isUnboxedTuple HsUnboxedTuple = True+isUnboxedTuple _ = False

@@ -7,12 +7,14 @@  import Test.Tasty import Test.Tasty.HUnit+import System.FilePath import System.Directory as Directory import System.Environment import qualified System.FilePath as FilePath import System.IO.Extra import Control.Monad import Data.List+import Data.Maybe  import Language.Haskell.GhclibParserEx.Config import Language.Haskell.GhclibParserEx.DynFlags@@ -21,6 +23,7 @@ import Language.Haskell.GhclibParserEx.Fixity import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.Pat  #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs@@ -50,6 +53,7 @@   , fixityTests   , extendInstancesTests   , expressionPredicateTests+  , patternPredicateTests   , dynFlagsTests   ] @@ -111,8 +115,8 @@   , testCase "Declaration (2)" $ -- Example from https://github.com/ndmitchell/hlint/issues/842.       chkParseResult report flags $         parseDeclaration "infixr 4 <%@~" flags-  , testCase "File" $ do-      foo <- makeFile "Foo.hs" $ unlines+  , testCase "File" $ withTempDir $ \tmpDir -> do+      foo <- makeFile (tmpDir </> "Foo.hs") $ unlines         ["{-# LANGUAGE ScopedTypeVariables #-}"         , "module Foo (readMany) where"         , "import Data.List"@@ -146,6 +150,17 @@ #endif         _ -> 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+        _ -> assertFailure "parse error"+ fixityTests :: TestTree fixityTests = testGroup "Fixity tests"   [ testCase "Expression" $ do@@ -255,9 +270,28 @@     flags = foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig)               [ TemplateHaskell, QuasiQuotes, TypeApplications, LambdaCase ] +patternPredicateTests :: TestTree+patternPredicateTests = testGroup "Pattern predicate tests"+  [ 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 "fromPChar" $ test "'a'" $ assert' . (== Just 'a') . fromPChar+  , testCase "fromPChar" $ test "\"a\"" $ assert' . isNothing . fromPChar+  ]+  where+    assert' = assertBool ""+    test s = patTest s flags+    flags = foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig)+              [ TemplateHaskell, QuasiQuotes, TypeApplications, LambdaCase ]+ dynFlagsTests :: TestTree dynFlagsTests = testGroup "DynFlags tests"-  [ testCase "extensionImplications" $ do+  [ testCase "readExtension" $ assertBool "parse DeriveTraversable" (readExtension "DeriveTraversable" == Just DeriveTraversable)+  , testCase "readExtension" $ assertBool "parse DeriveTravresable" (isNothing $ readExtension "DeriveTravresable")+  , testCase "extensionImplications" $ do       Just (_, (es, ds)) <- return $ find (\(e, _) -> e == DeriveTraversable) extensionImplications       assertBool "no extensions disabled" (null ds)       assertBool "two extensions enabled" $ DeriveFunctor `elem` es && DeriveFoldable `elem` es