diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/ghc-lib-parser-ex.cabal b/ghc-lib-parser-ex.cabal --- a/ghc-lib-parser-ex.cabal +++ b/ghc-lib-parser-ex.cabal @@ -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 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.*, diff --git a/src/Language/Haskell/GhclibParserEx/DynFlags.hs b/src/Language/Haskell/GhclibParserEx/DynFlags.hs --- a/src/Language/Haskell/GhclibParserEx/DynFlags.hs +++ b/src/Language/Haskell/GhclibParserEx/DynFlags.hs @@ -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]))] diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs @@ -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 diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs @@ -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 diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs @@ -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 diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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