ghc-lib-parser-ex (empty) → 0.20200102
raw patch · 11 files changed
+870/−0 lines, 11 filesdep +basedep +bytestringdep +directorysetup-changed
Dependencies added: base, bytestring, directory, extra, filepath, ghc, ghc-boot-th, ghc-lib-parser, ghc-lib-parser-ex, tasty, tasty-hunit, uniplate
Files
- ChangeLog.md +3/−0
- LICENSE +34/−0
- README.md +27/−0
- Setup.hs +2/−0
- cbits/ghclib_api.h +33/−0
- ghc-lib-parser-ex.cabal +83/−0
- src/Language/Haskell/GhclibParserEx/Dump.hs +235/−0
- src/Language/Haskell/GhclibParserEx/Fixity.hs +173/−0
- src/Language/Haskell/GhclibParserEx/Outputable.hs +9/−0
- src/Language/Haskell/GhclibParserEx/Parse.hs +149/−0
- test/Test.hs +122/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for ghc-lib-parser-ex++## 8.8.1.20191204, released 2020-01-18
+ LICENSE view
@@ -0,0 +1,34 @@+Copyright Shayne Fletcher 2020.++* BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause)++BSD 3-Clause License+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,27 @@+# ghc-lib-parser-ex [](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++The `ghc-lib-parser-ex` package contains GHC API parse tree utilities. It works with or without [`ghc-lib-parser`](https://github.com/digital-asset/ghc-lib).++## Using `ghc-lib-parser-ex`++The package `ghc-lib-parser-ex` is available on [Hackage](https://hackage.haskell.org/) e.g. `cabal install ghc-lib-parser-ex`. There are two release streams within the `ghc-lib-parser-ex` name (tracking released `ghc-lib-parser` versions exactly):++* Version 8.10.1 will be the `ghc-lib-parser-ex` for use against `ghc-lib-parser-8.10.1`(or the released GHC 8.10.1);+* Version 0.20190204 is for use against [`ghc-lib-parser-0.20190204`](http://hackage.haskell.org/package/ghc-lib-0.20190204).++### Building `ghc-lib-parser-ex`++You can build with `stack build` and test with `stack test`. You can also produce `ghc-lib-parser-ex` package distributions by executing the CI script (which incidentally builds everything and runs the tests).+```bash+# Setup+git clone git@github.com:shayne-fletcher/ghc-lib-parser-ex.git+cd ghc-lib-parser-ex+stack runhaskell --package extra --package optparse-applicative CI.hs+```+Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more configurability options.++## Releasing `ghc-lib` (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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/ghclib_api.h view
@@ -0,0 +1,33 @@+/*+Copyright (c) 2020, Shayne Fletcher. All rights+reserved. SPDX-License-Identifier: BSD-3-Clause.+ */++#if !defined(GHCLIB_API_H)+# define GHCLIB_API_H++# if !defined(GHCLIB_API_811) && !defined(GHCLIBAPI_810) && !defined(GHCLIB_API_808)+# if defined(MIN_VERSION_ghc_lib_parser)+# if !MIN_VERSION_ghc_lib_parser(1, 0, 0)+# define GHCLIB_API_811+# elif MIN_VERSION_ghc_lib_parser(8, 10, 0)+# define GHCLIBAPI_810+# elif MIN_VERSION_ghc_lib_parser(8, 8, 0)+# define GHCLIB_API_808+# else+# error Unsupported GHC API version+# endif+# else+# if __GLASGOW_HASKELL__ == 811+# define GHCLIB_API_811+# elif __GLASGOW_HASKELL__ == 810+# define GHCLIB_API_810+# elif __GLASGOW_HASKELL__ == 808+# define GHCLIB_API_808+# else+# error Unsupported GHC API version+# endif+# endif+# endif++#endif
+ ghc-lib-parser-ex.cabal view
@@ -0,0 +1,83 @@+cabal-version: >= 1.18+name: ghc-lib-parser-ex+version: 0.20200102+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+author: Shayne Fletcher+maintainer: shayne@shaynefletcher.org+copyright: Copyright © 2020, Shayne Fletcher. All rights reserved.+license: BSD3+license-file: LICENSE+category: Development+synopsis: Algorithms on GHC parse trees+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+extra-source-files:+ cbits/ghclib_api.h++source-repository head+ type: git+ location: https://github.com/shayne-fletcher/ghc-lib-parser-ex++flag ghc-lib+ default: False+ manual: True+ description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported++library+ exposed-modules:+ 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:+ src+ build-depends:+ base >=4.7 && <5,+ uniplate >= 1.5,+ bytestring >= 0.10.8.2+ if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)+ build-depends:+ ghc == 8.8.*,+ ghc-boot-th+ else+ build-depends:+ ghc-lib-parser == 0.20200102+ include-dirs:+ cbits+ install-includes:+ cbits/ghclib_api.h+ default-language: Haskell2010++test-suite ghc-lib-parser-ex-test+ type: exitcode-stdio-1.0+ main-is:+ Test.hs+ other-modules:+ Paths_ghc_lib_parser_ex+ hs-source-dirs:+ test+ include-dirs:+ cbits+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , tasty >= 1.2.3+ , tasty-hunit >= 0.10.0+ , directory >= 1.3.3+ , filepath >= 1.4.2+ , extra >=1.6+ , ghc-lib-parser-ex+ if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)+ build-depends:+ ghc == 8.8.*,+ ghc-boot-th+ else+ build-depends:+ ghc-lib-parser == 0.20200102+ default-language: Haskell2010
+ src/Language/Haskell/GhclibParserEx/Dump.hs view
@@ -0,0 +1,235 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.+{-+Currently 'showAstData' is only available in ghc-lib. I intend to+move it to ghc-lib-parser. Then, we'll be able to get at it with+something like,++ #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ import GHC.Hs.Dump+ #else+ import HsDumpAst+ #endif++The implementation is reproduced here until that time.+-}+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+{- HLINT ignore -} -- Not our code.+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+#include "ghclib_api.h"+module Language.Haskell.GhclibParserEx.Dump(+ showAstData+ , BlankSrcSpan(..),+) where++import Prelude as X hiding ((<>))++import Data.Data hiding (Fixity)+import Bag+import BasicTypes+import FastString+import NameSet+import Name+import DataCon+import SrcLoc+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import OccName hiding (occName)+import Var+import Module+import Outputable++import qualified Data.ByteString as B++data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+ deriving (Eq,Show)++-- | Show a GHC syntax tree. This parameterised because it is also used for+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked+-- out, to avoid comparing locations, only structure+showAstData :: Data a => BlankSrcSpan -> a -> SDoc+showAstData b a0 = blankLine $$ showAstData' a0+ where+ showAstData' :: Data a => a -> SDoc+ showAstData' =+ generic+ `ext1Q` list+ `extQ` string `extQ` fastString `extQ` srcSpan+ `extQ` lit `extQ` litr `extQ` litt+ `extQ` bytestring+ `extQ` name `extQ` occName `extQ` moduleName `extQ` var+ `extQ` dataCon+ `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+ `extQ` fixity+ `ext2Q` located++ where generic :: Data a => a -> SDoc+ generic t = parens $ text (showConstr (toConstr t))+ $$ vcat (gmapQ showAstData' t)++ string :: String -> SDoc+ string = text . normalize_newlines . show++ fastString :: FastString -> SDoc+ fastString s = braces $+ text "FastString: "+ <> text (normalize_newlines . show $ s)++ bytestring :: B.ByteString -> SDoc+ bytestring = text . normalize_newlines . show++ list [] = brackets empty+ list [x] = brackets (showAstData' x)+ list (x1 : x2 : xs) = (text "[" <> showAstData' x1)+ $$ go x2 xs+ where+ go y [] = text "," <> showAstData' y <> text "]"+ go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys++ -- Eliminate word-size dependence+ lit :: HsLit GhcPs -> SDoc+ lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s+ lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+ lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s+ lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s+ lit l = generic l++ litr :: HsLit GhcRn -> SDoc+ litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s+ litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+ litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s+ litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s+ litr l = generic l++ litt :: HsLit GhcTc -> SDoc+ litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s+ litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+ litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s+ litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s+ litt l = generic l++ numericLit :: String -> Integer -> SourceText -> SDoc+ numericLit tag x s = braces $ hsep [ text tag+ , generic x+ , generic s ]++ name :: Name -> SDoc+ name nm = braces $ text "Name: " <> ppr nm++ occName n = braces $+ text "OccName: "+ <> text (OccName.occNameString n)++ moduleName :: ModuleName -> SDoc+ moduleName m = braces $ text "ModuleName: " <> ppr m++ srcSpan :: SrcSpan -> SDoc+ srcSpan ss = case b of+ BlankSrcSpan -> text "{ ss }"+ NoBlankSrcSpan -> braces $ char ' ' <>+ (hang (ppr ss) 1+ -- TODO: show annotations here+ (text ""))++ var :: Var -> SDoc+ var v = braces $ text "Var: " <> ppr v++ dataCon :: DataCon -> SDoc+ dataCon c = braces $ text "DataCon: " <> ppr c++ bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc+ bagRdrName bg = braces $+ text "Bag(Located (HsBind GhcPs)):"+ $$ (list . bagToList $ bg)++ bagName :: Bag (Located (HsBind GhcRn)) -> SDoc+ bagName bg = braces $+ text "Bag(Located (HsBind Name)):"+ $$ (list . bagToList $ bg)++ bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc+ bagVar bg = braces $+ text "Bag(Located (HsBind Var)):"+ $$ (list . bagToList $ bg)++ nameSet ns = braces $+ text "NameSet:"+ $$ (list . nameSetElemsStable $ ns)++ fixity :: Fixity -> SDoc+ fixity fx = braces $+ text "Fixity: "+ <> ppr fx++ located :: (Data b,Data loc) => GenLocated loc b -> SDoc+ located (L ss a) = parens $+ case cast ss of+ Just (s :: SrcSpan) ->+ srcSpan s+ Nothing -> text "nnnnnnnn"+ $$ showAstData' a++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs) = x:normalize_newlines xs+normalize_newlines [] = []++{-+************************************************************************+* *+* Copied from syb+* *+************************************************************************+-}+++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | Extend a generic query by a type-specific case+extQ :: ( Typeable a+ , Typeable b+ )+ => (a -> q)+ -> (b -> q)+ -> a+ -> q+extQ f g a = maybe (f a) g (cast a)++-- | Type extension of queries for type constructors+ext1Q :: (Data d, Typeable t)+ => (d -> q)+ -> (forall e. Data e => t e -> q)+ -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable t)+ => (d -> q)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+ -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))++-- | Flexible type extension+ext1 :: (Data a, Typeable t)+ => c a+ -> (forall d. Data d => c (t d))+ -> c a+ext1 def ext = maybe def id (dataCast1 ext)++-- | Flexible type extension+ext2 :: (Data a, Typeable t)+ => c a+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+ -> c a+ext2 def ext = maybe def id (dataCast2 ext)
+ src/Language/Haskell/GhclibParserEx/Fixity.hs view
@@ -0,0 +1,173 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.+--+-- Adapted from (1) https://github.com/mpickering/apply-refact.git and+-- (2) https://gitlab.haskell.org/ghc/ghc ('compiler/renamer/RnTypes.hs').++{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+#include "ghclib_api.h"++module Language.Haskell.GhclibParserEx.Fixity(applyFixities) where++import BasicTypes+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import RdrName+import OccName+import SrcLoc+import Data.Maybe+import Data.Data hiding (Fixity)+import Data.Generics.Uniplate.Data++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+noExt :: NoExtField+noExt = noExtField+#endif++-- | Rearrange a parse tree to account for fixities.+applyFixities :: Data a => [(String, Fixity)] -> a -> a+applyFixities fixities m =+ let m' = transformBi (expFix fixities) m+ m'' = transformBi (patFix fixities) m'+ in m''++expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs+expFix fixities (L loc (OpApp _ l op r)) =+ mkOpApp (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r+expFix _ e = e++-- 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)+patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) =+ L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2)+#else+patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) =+ mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2+#endif+patFix _ p = p++mkConOpPat ::+ [(String, Fixity)]+ -> Located RdrName -> Fixity+ -> LPat GhcPs -> LPat GhcPs+ -> Pat GhcPs+#if defined (GHCLIB_API_811) || 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+ | nofix_error = ConPatIn op2 (InfixCon p1 p2)+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2)))+#else+ | associate_right = let new_p = mkConOpPat fs op2 fix2 p12 p2 in ConPatIn op1 (InfixCon p11 (cL loc new_p))+#endif+ | otherwise = ConPatIn op2 (InfixCon p1 p2)+ where+ fix1 = findFixity' fs op1+ (nofix_error, associate_right) = compareFixity fix1 fix2+mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2)++mkOpApp ::+ [(String, Fixity)]+ -> SrcSpan+ -> LHsExpr GhcPs -- Left operand; already rearrange.+ -> LHsExpr GhcPs -> Fixity -- Operator and fixity.+ -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp).+ -> LHsExpr GhcPs+-- (e11 `op1` e12) `op2` e2+mkOpApp fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2+ | nofix_error = L loc (OpApp noExt e1 op2 e2)+ | associate_right = L loc (OpApp x1 e11 op1 (mkOpApp fs loc' e12 op2 fix2 e2 ))+ where+ loc'= combineLocs e12 e2+ fix1 = findFixity fs op1+ (nofix_error, associate_right) = compareFixity fix1 fix2+-- (- neg_arg) `op` e2+mkOpApp fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+ | nofix_error = L loc (OpApp noExt e1 op2 e2)+ | associate_right = L loc (NegApp noExt (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name)+ where+ loc' = combineLocs neg_arg e2+ (nofix_error, associate_right) = compareFixity negateFixity fix2+-- e1 `op` - neg_arg+mkOpApp _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right.+ | not associate_right = L loc (OpApp noExt e1 op1 e2)-- We *want* right association.+ where+ (_, associate_right) = compareFixity fix1 negateFixity+ -- Default case, no rearrangment.+mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExt e1 op e2)++getIdent :: LHsExpr GhcPs -> String+getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n+getIdent _ = error "Must be HsVar"++-- If there are no fixities provided, give 'baseFixities.+getFixities :: [(String, Fixity)] -> [(String, Fixity)]+getFixities fixities = if null fixities then baseFixities else fixities++findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity+findFixity fs r = askFix fs (getIdent r) -- Expressions.++findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity+findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r) -- Patterns.++askFix :: [(String, Fixity)] -> String -> Fixity+askFix xs = \k -> lookupWithDefault defaultFixity k xs+ where lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1++-- All fixities defined in the Prelude.+preludeFixities :: [(String, Fixity)]+preludeFixities = concat+ [ infixr_ 9 ["."]+ , infixl_ 9 ["!!"]+ , infixr_ 8 ["^","^^","**"]+ , infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"]+ , infixl_ 6 ["+","-"]+ , infixr_ 5 [":","++"]+ , infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"]+ , infixr_ 3 ["&&"]+ , infixr_ 2 ["||"]+ , infixl_ 1 [">>",">>="]+ , infixr_ 1 ["=<<"]+ , infixr_ 0 ["$","$!","seq"]+ ]++-- All fixities defined in the base package. Note that the @+++@+-- operator appears in both Control.Arrows and+-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in+-- this list is that of Control.Arrows.+baseFixities :: [(String, Fixity)]+baseFixities = preludeFixities ++ concat+ [ infixl_ 9 ["!","//","!:"]+ , infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"]+ , infixl_ 7 [".&."]+ , infixl_ 6 ["xor"]+ , infix_ 6 [":+"]+ , infixl_ 5 [".|."]+ , infixr_ 5 ["+:+","<++","<+>"] -- Fixity conflict for +++ between ReadP and Arrow.+ , infix_ 5 ["\\\\"]+ , infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"]+ , infix_ 4 ["elemP","notElemP"]+ , infixl_ 3 ["<|>"]+ , infixr_ 3 ["&&&","***"]+ , infixr_ 2 ["+++","|||"]+ , infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]+ , infixl_ 0 ["on"]+ , infixr_ 0 ["par","pseq"]+ ]++infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)]+infixr_ = fixity InfixR+infixl_ = fixity InfixL+infix_ = fixity InfixN++fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]+fixity a p = map (,Fixity (SourceText "") p a)
+ src/Language/Haskell/GhclibParserEx/Outputable.hs view
@@ -0,0 +1,9 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++module Language.Haskell.GhclibParserEx.Outputable (unsafePrettyPrint) where++import Outputable++unsafePrettyPrint :: (Outputable.Outputable a) => a -> String+unsafePrettyPrint = Outputable.showSDocUnsafe . Outputable.ppr
+ src/Language/Haskell/GhclibParserEx/Parse.hs view
@@ -0,0 +1,149 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++{-# OPTIONS_GHC -Wno-missing-fields #-}+{-# LANGUAGE CPP #-}+#include "ghclib_api.h"++module Language.Haskell.GhclibParserEx.Parse(+ parse+ , parseExpr+ , parseImport+ , parseDeclaration+ , parseFile+ , parsePragmasIntoDynFlags+ , fakeSettings+ , fakeLlvmConfig+ )+ where++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+import RdrHsSyn+#else+import HsSyn+#endif+import Config+import DynFlags+import StringBuffer+import Fingerprint+import Lexer+import qualified Parser+import FastString+import SrcLoc+import Panic+import HscTypes+import HeaderInfo++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Platform+import ToolSettings+#else+import Platform+#endif++fakeSettings :: Settings+fakeSettings = Settings+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ { sGhcNameVersion=ghcNameVersion+ , sFileSettings=fileSettings+ , sTargetPlatform=platform+ , sPlatformMisc=platformMisc+ , sPlatformConstants=platformConstants+ , sToolSettings=toolSettings+ }+#else+ { sTargetPlatform=platform+ , sPlatformConstants=platformConstants+ , sProjectVersion=cProjectVersion+ , sProgramName="ghc"+ , sOpt_P_fingerprint=fingerprint0+ }+#endif+ where+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ toolSettings = ToolSettings {+ toolSettings_opt_P_fingerprint=fingerprint0+ }+ fileSettings = FileSettings {}+ platformMisc = PlatformMisc {}+ ghcNameVersion =+ GhcNameVersion{ghcNameVersion_programName="ghc"+ ,ghcNameVersion_projectVersion=cProjectVersion+ }+#endif+ platform =+ Platform{+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ platformWordSize = PW8+ , platformMini = PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown}+#else+ platformWordSize=8+ , platformOS=OSUnknown+#endif+ , platformUnregisterised=True+ }+ platformConstants =+ PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+fakeLlvmConfig :: LlvmConfig+fakeLlvmConfig = LlvmConfig [] []+#else+fakeLlvmConfig :: (LlvmTargets, LlvmPasses)+fakeLlvmConfig = ([], [])+#endif++parse :: P a -> String -> DynFlags -> ParseResult a+parse p str flags =+ Lexer.unP p parseState+ where+ location = mkRealSrcLoc (mkFastString "<string>") 1 1+ buffer = stringToStringBuffer str+ parseState = mkPState flags buffer location++#if defined (GHCLIB_API_811)+parseExpr :: String -> DynFlags -> ParseResult RdrHsSyn.ECP+#else+parseExpr :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)+#endif+parseExpr = parse Parser.parseExpression++parseImport :: String -> DynFlags -> ParseResult (LImportDecl GhcPs)+parseImport = parse Parser.parseImport++parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs)+parseDeclaration = parse Parser.parseDeclaration++#if defined (GHC_API_811)+parseFile :: String+ -> DynFlags+ -> String+ -> ParseResult (Located HsModule)+#else+parseFile :: String+ -> DynFlags+ -> String+ -> ParseResult (Located (HsModule GhcPs))+#endif+parseFile filename flags str =+ unP Parser.parseModule parseState+ where+ location = mkRealSrcLoc (mkFastString filename) 1 1+ buffer = stringToStringBuffer str+ parseState = mkPState flags buffer location++parsePragmasIntoDynFlags :: DynFlags+ -> FilePath+ -> String+ -> IO (Either String DynFlags)+parsePragmasIntoDynFlags flags file str =+ catchErrors $ do+ let opts = getOptions flags (stringToStringBuffer str) file+ (flags, _, _) <- parseDynamicFilePragma flags opts+ return $ Right (flags `gopt_set` Opt_KeepRawTokenStream)+ where+ catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)+ catchErrors act = handleGhcException reportErr+ (handleSourceError reportErr act)+ reportErr e = return $ Left (show e)
+ test/Test.hs view
@@ -0,0 +1,122 @@+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.+-- SPDX-License-Identifier: BSD-3-Clause.++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+#include "ghclib_api.h"++import Test.Tasty+import Test.Tasty.HUnit+import System.Directory as Directory+import System.Environment+import qualified System.FilePath as FilePath+import System.IO.Extra+import Control.Monad++import Language.Haskell.GhclibParserEx.Parse+import Language.Haskell.GhclibParserEx.Dump+import Language.Haskell.GhclibParserEx.Fixity++#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+import GHC.Hs+#else+import HsSyn+#endif+import DynFlags+import Lexer+import Outputable+import ErrUtils+import RdrHsSyn+#if defined (GHCLIB_API_808)+import Bag+#endif++main :: IO ()+main = do+ setEnv "TASTY_NUM_THREADS" "1"+ setUnsafeGlobalDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig)+ defaultMain tests++tests :: TestTree+tests = testGroup " All tests" [parseTests, fixityTests]++chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO ()+chkParseResult report flags = \case+ POk s _ -> do+ let (wrns, errs) = getMessages s flags+ when (not (null errs) || not (null wrns)) $+ assertFailure (report flags wrns ++ report flags errs)+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ PFailed s -> assertFailure (report flags $ snd (getMessages s flags))+#else+ PFailed _ loc err -> assertFailure (report flags $ unitBag $ mkPlainErrMsg flags loc err)+#endif++parseTests :: TestTree+parseTests = testGroup "Parse tests"+ [+ testCase "Expression" $ do+ let flags = defaultDynFlags fakeSettings fakeLlvmConfig+ chkParseResult report flags $+ parseExpr "unfoldr $ listToMaybe . concatMap reads . tails" flags+ , testCase "Import" $ do+ let flags = defaultDynFlags fakeSettings fakeLlvmConfig+ chkParseResult report flags $+ parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags+ , testCase "Declaration" $ do+ let flags = defaultDynFlags fakeSettings fakeLlvmConfig+ chkParseResult report flags $+ parseDeclaration (+ unlines [+ "fact :: Int -> Int"+ , "fact n = if n <= 1 then 1 else n * fact (n - 1)"+ ]) flags+ , testCase "File" $ do+ foo <- makeFile "Foo.hs" $ unlines+ [ "module Foo (readMany) where"+ , "import Data.List"+ , "import Data.Maybe"+ , "readMany = unfoldr $ listToMaybe . concatMap reads . tails"+ ]+ s <- readFile' foo+ parsePragmasIntoDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) foo s >>= \case+ Left msg -> assertFailure msg+ Right flags ->+ chkParseResult report flags $ parseFile foo (flags `gopt_set` Opt_KeepRawTokenStream) s+ ]+ where+ report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ]++fixityTests :: TestTree+fixityTests = testGroup "Fixity tests"+ [+ testCase "Expression" $ do+ let flags = defaultDynFlags fakeSettings fakeLlvmConfig+ case parseExpr "1 + 2 * 3" flags of+ POk s e ->+#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+ assertBool "parse tree not affected" $+ showSDocUnsafe (showAstData BlankSrcSpan e) /=+ showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e))+#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)+ PFailed{} -> assertFailure "ecp failure"+#endif+ PFailed{} -> assertFailure "parse error"+ , testCase "Pattern" $ do+ let flags = defaultDynFlags fakeSettings fakeLlvmConfig+ case parseDeclaration "f (1 : 2 :[]) = 1" flags of+ POk _ d ->+ assertBool "parse tree not affected" $+ showSDocUnsafe (showAstData BlankSrcSpan d) /=+ showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] d))+ PFailed{} -> assertFailure "parse error"+ ]++makeFile :: FilePath -> String -> IO FilePath+makeFile relPath contents = do+ Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath+ writeFile relPath contents+ return relPath