diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Changelog for ghc-lib-parser-ex +## Unreleased changes + +## 8.8.4.0 released 2020-02-01 +- New modules: + - `Language.Haskell.GhclibparserEx.GHC.Hs.Expr` +- Moved modules: + - `Language.Haskell.GhclibparserEx.HsExtendInstances` -> + `Language.Haskell.GhclibparserEx.GHC.Hs.ExtendInstances`; + +## 0.20200201.1.0 released 2020-02-01 +- New modules: + - `Language.Haskell.GhclibparserEx.HsExtendInstances`. + ## 8.8.3.0 released 2020-01-25 - Change in versioning scheme; - New modules: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# ghc-lib-parser-ex [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) +# ghc-lib-parser-ex [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage version](https://img.shields.io/hackage/v/ghc-lib-parser-ex.svg?label=Hackage)](https://hackage.haskell.org/package/ghc-lib-parser-ex) [![Stackage version](https://www.stackage.org/package/ghc-lib-parser-ex/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghc-lib-parser-ex) [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) Copyright © 2020, Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause @@ -29,4 +29,4 @@ ## Releasing `ghc-lib-parser-ex` (notes for maintainers) -Build `ghc-lib-parser-ex` using the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). +Update the [changelog](./ChangeLog.md), `git tag && git push origin ` then build via the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). 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.3.0 +version: 8.8.4.0 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 @@ -12,7 +12,7 @@ category: Development synopsis: Algorithms on GHC parse trees build-type: Simple -tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4 +tested-with: GHC==8.8.2, GHC==8.6.5 extra-source-files: README.md ChangeLog.md @@ -30,11 +30,13 @@ library exposed-modules: Language.Haskell.GhclibParserEx.Config + Language.Haskell.GhclibParserEx.Dump Language.Haskell.GhclibParserEx.DynFlags + Language.Haskell.GhclibParserEx.Fixity + Language.Haskell.GhclibParserEx.GHC.Hs.Expr + Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances Language.Haskell.GhclibParserEx.Parse Language.Haskell.GhclibParserEx.Outputable - Language.Haskell.GhclibParserEx.Dump - Language.Haskell.GhclibParserEx.Fixity other-modules: Paths_ghc_lib_parser_ex hs-source-dirs: diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs @@ -0,0 +1,139 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# OPTIONS_GHC -Wno-missing-fields #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +#include "ghclib_api.h" + +module Language.Haskell.GhclibParserEx.GHC.Hs.Expr( + 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, + hasFieldsDotDot, + varToStr, strToVar, + fromChar + ) where + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +import GHC.Hs +#else +import HsSyn +#endif +import SrcLoc +import RdrName +import OccName +import Name +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 + +isDot, isDol, isReturn, isSection, isRecConstr, isRecUpdate, + isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isQuasiQuote, + isLambda, isDotApp, isTypeApp, isWHNF, isLCase :: LHsExpr GhcPs -> Bool +isDol = isTag "$" +isDot = isTag "." +isReturn x = isTag "return" x || isTag "pure" x -- Allow both 'pure' and 'return' as they have the same semantics. +isSection = \case (L _ SectionL{}) -> True ; (L _ SectionR{}) -> True; _ -> False +isRecConstr = \case (L _ RecordCon{}) -> True; _ -> False +isRecUpdate = \case (L _ RecordUpd{}) -> True; _ -> False +isVar = \case (L _ HsVar{}) -> True; _ -> False +isPar = \case (L _ HsPar{}) -> True; _ -> False +isApp = \case (L _ HsApp{}) -> True; _ -> False +isOpApp = \case (L _ OpApp{}) -> True; _ -> False +isAnyApp x = isApp x || isOpApp x +isLexeme = \case (L _ HsVar{}) -> True; (L _ HsOverLit{}) -> True; (L _ HsLit{}) -> True; _ -> False +isLambda = \case (L _ HsLam{}) -> True; _ -> False +isQuasiQuote = \case (L _ (HsSpliceE _ HsQuasiQuote{})) -> True; _ -> False +isDotApp = \case (L _ (OpApp _ _ op _)) -> isDot op; _ -> False +isTypeApp = \case (L _ HsAppType{}) -> True; _ -> False +isWHNF = \case + (L _ (HsVar _ (L _ x))) -> isRdrDataCon x + (L _ (HsLit _ x)) -> case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True + (L _ HsLam{}) -> True + (L _ ExplicitTuple{}) -> True + (L _ ExplicitList{}) -> True + (L _ (HsPar _ x)) -> isWHNF x + (L _ (ExprWithTySig _ x _)) -> isWHNF x + -- Other (unknown) constructors may have bang patterns in them, so + -- approximate. + (L _ (HsApp _ (L _ (HsVar _ (L _ x))) _)) + | occNameString (rdrNameOcc x) `elem` ["Just", "Left", "Right"] -> True + _ -> False +isLCase = \case (L _ HsLamCase{}) -> True; _ -> False + +-- Field is punned e.g. '{foo}'. +isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool +isFieldPun = \case (L _ HsRecField {hsRecPun=True}) -> True; _ -> False + +-- Contains a '..' as in 'Foo{..}' +hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool +hasFieldsDotDot = \case HsRecFields {rec_dotdot=Just _} -> True; _ -> False + +isRecStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool +isRecStmt = \case RecStmt{} -> True; _ -> False + +isParComp :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool +isParComp = \case ParStmt{} -> True; _ -> False + +isMDo :: HsStmtContext Name -> Bool +isMDo = \case MDoExpr -> True; _ -> False + +isTupleSection :: HsTupArg GhcPs -> Bool +isTupleSection = \case Missing{} -> True; _ -> False + +isString :: HsLit GhcPs -> Bool +isString = \case HsString{} -> True; _ -> False + +isPrimLiteral :: HsLit GhcPs -> Bool +isPrimLiteral = \case + HsCharPrim{} -> True + HsStringPrim{} -> True + HsIntPrim{} -> True + HsWordPrim{} -> True + HsInt64Prim{} -> True + HsWord64Prim{} -> True + HsFloatPrim{} -> True + HsDoublePrim{} -> True + _ -> False + +isSpliceDecl :: HsExpr GhcPs -> Bool +isSpliceDecl = \case HsSpliceE{} -> True; _ -> False + +-- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. +isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool +isFieldWildcard = \case +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" +#else + (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True +#endif + (L _ HsRecField {hsRecPun=True}) -> True + (L _ HsRecField {}) -> False + +isUnboxed :: Boxity -> Bool +isUnboxed = \case Unboxed -> True; _ -> False + +varToStr :: LHsExpr GhcPs -> String +varToStr (L _ (HsVar _ (L _ n))) + | n == consDataCon_RDR = ":" + | n == nameRdrName nilDataConName = "[]" + | n == nameRdrName (getName (tupleDataCon Boxed 0)) = "()" + | otherwise = occNameString (rdrNameOcc n) +varToStr _ = "" + +strToVar :: String -> LHsExpr GhcPs +strToVar x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x)) + +fromChar :: LHsExpr GhcPs -> Maybe Char +fromChar = \case (L _ (HsLit _ (HsChar _ x))) -> Just x; _ -> Nothing diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs @@ -0,0 +1,50 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances ( + HsExtendInstances(..), extendInstances, astEq, astListEq) +where + +-- At times, there are terms in Haskell syntax we work with that are +-- not in `Eq`, `Show` or `Ord` and we need them to be. + +-- This work-around resorts to implementing Eq and Ord via +-- lexicographic string comparisons. As long as two different terms +-- never map to the same string, basing `Eq` and `Ord` on their string +-- representations rather than the terms themselves, leads to +-- identical results. + +import Outputable +import Data.Data +import Data.Function + +import Language.Haskell.GhclibParserEx.Dump + +newtype HsExtendInstances a = + HsExtendInstances { unextendInstances :: a } + deriving Outputable + +extendInstances :: a -> HsExtendInstances a +extendInstances = HsExtendInstances + +-- Use 'showAstData'. This is preferable to 'ppr' in that trees that +-- only differ in arrangement due to fixities will produce differing +-- string representations. +toStr :: Data a => HsExtendInstances a -> String +toStr (HsExtendInstances e) = + Outputable.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 + +astEq :: Data a => a -> a -> Bool +astEq a b = extendInstances a == extendInstances b + +astListEq :: Data a => [a] -> [a] -> Bool +astListEq as bs = length as == length bs && all (uncurry astEq) (zip as bs) + +-- Use 'ppr' for 'Show'. +instance Outputable a => Show (HsExtendInstances a) where + show (HsExtendInstances e) = Outputable.showSDocUnsafe $ Outputable.ppr e diff --git a/src/Language/Haskell/GhclibParserEx/Parse.hs b/src/Language/Haskell/GhclibParserEx/Parse.hs --- a/src/Language/Haskell/GhclibParserEx/Parse.hs +++ b/src/Language/Haskell/GhclibParserEx/Parse.hs @@ -37,7 +37,11 @@ import FastString import SrcLoc import BkpSyn +#if defined (GHCLIB_API_811) +import UnitInfo +#else import PackageConfig +#endif import RdrName parse :: P a -> String -> DynFlags -> ParseResult a @@ -48,10 +52,18 @@ buffer = stringToStringBuffer str parseState = mkPState flags buffer location +#if defined (GHCLIB_API_811) +parseModule :: String -> DynFlags -> ParseResult (Located HsModule) +#else parseModule :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) +#endif parseModule = parse Parser.parseModule +#if defined (GHCLIB_API_811) +parseSignature :: String -> DynFlags -> ParseResult (Located HsModule) +#else parseSignature :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) +#endif parseSignature = parse Parser.parseSignature parseImport :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) @@ -88,10 +100,14 @@ parseType :: String -> DynFlags -> ParseResult (LHsType GhcPs) parseType = parse Parser.parseType +#if defined(GHCLIB_API_811) +parseHeader :: String -> DynFlags -> ParseResult (Located HsModule) +#else parseHeader :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) +#endif parseHeader = parse Parser.parseHeader -#if defined (GHC_API_811) +#if defined (GHCLIB_API_811) parseFile :: String -> DynFlags -> String diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -18,6 +18,7 @@ import Language.Haskell.GhclibParserEx.Parse import Language.Haskell.GhclibParserEx.Dump import Language.Haskell.GhclibParserEx.Fixity +import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs @@ -38,7 +39,7 @@ defaultMain tests tests :: TestTree -tests = testGroup " All tests" [parseTests, fixityTests] +tests = testGroup " All tests" [parseTests, fixityTests, extendInstancesTests] chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO () chkParseResult report flags = \case @@ -87,9 +88,12 @@ , testCase "Expression" $ chkParseResult report flags $ parseExpression "unfoldr $ listToMaybe . concatMap reads . tails" flags - , testCase "Declaration" $ + , testCase "Declaration (1)" $ chkParseResult report flags $ parseDeclaration "fact n = if n <= 1 then 1 else n * fact (n - 1)" flags + , 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 ["{-# LANGUAGE ScopedTypeVariables #-}" @@ -144,3 +148,34 @@ Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath writeFile relPath contents return relPath + +extendInstancesTests :: TestTree +extendInstancesTests = testGroup "Extend instances tests" + [ + testCase "Eq, Ord" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + case parseExpression "1 + 2 * 3" 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 + do + e' <- return $ applyFixities [] e + assertBool "astEq" $ astEq e e + assertBool "astEq" $ not (astEq e e') + e <- return $ extendInstances e + e' <- return $ extendInstances e' + assertBool "==" $ e == e + assertBool "/=" $ e /= e' + assertBool "< " $ e' < e + assertBool ">=" $ e >= e' +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + _ -> assertFailure "ecp failure" +#endif + _ -> assertFailure "parse error" + ]