ghc-hs-meta 0.1.0.0 → 0.1.1.0
raw patch · 6 files changed
+63/−20 lines, 6 filesdep ~basedep ~ghcdep ~ghc-bootPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, ghc, ghc-boot, template-haskell
API changes (from Hackage documentation)
Files
- README.md +2/−2
- ghc-hs-meta.cabal +6/−6
- src/Language/Haskell/Meta/Parse.hs +20/−4
- src/Language/Haskell/Meta/Settings.hs +4/−0
- src/Language/Haskell/Meta/Translate.hs +30/−7
- test/Main.hs +1/−1
README.md view
@@ -1,4 +1,4 @@-# ghc-hs-meta+# ghc-meta Generate Template Haskell expressions from Haskell source code using the GHC parser. This package runs on GHC versions 8.10.7, 9.0.2, and 9.2.1.@@ -18,7 +18,7 @@ ## Thank you, PyF -This code originated from the excellent parser included in the [`PyF`](https://github.com/guibou/PyF) package.+This code originated from the excellent parser included in the [`PyF`](https://github.com/guibou/PyF) package. I extracted the relevant code and refactored/renamed things to be usable in a more general context. Without PyF, this could wouldn't have been possible. Thank you!
ghc-hs-meta.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: ghc-hs-meta-version: 0.1.0.0+version: 0.1.1.0 build-type: Simple author: Zachary Wood maintainer: zac.wood@hey.com@@ -10,7 +10,7 @@ synopsis: Translate Haskell source to Template Haskell expression description: Translate from Haskell source code to Template Haskell expressions using the GHC parser category: ghc,template-haskell-tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.1+tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.1 extra-source-files: CHANGELOG.md README.md @@ -26,10 +26,10 @@ LambdaCase ghc-options: -Wall build-depends:- base >= 4.14 && <4.17- , ghc >= 8.10.7 && < 9.3- , ghc-boot >= 8.10.7 && < 9.3- , template-haskell >= 2.16.0 && < 2.19+ base >= 4.14 && <4.18+ , ghc >= 8.10.7 && < 9.5+ , ghc-boot >= 8.10.7 && < 9.5+ , template-haskell >= 2.16.0 && < 2.20 , bytestring >= 0.10 && < 0.12 default-language: Haskell2010
src/Language/Haskell/Meta/Parse.hs view
@@ -4,12 +4,21 @@ -- | This module is here to parse Haskell expression using the GHC Api module Language.Haskell.Meta.Parse (parseExp, parseExpWithExts, parseExpWithFlags, parseHsExpr) where -#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0)+import GHC.Parser.Errors.Ppr ()+import GHC.Parser.Annotation (LocatedA)+import GHC.Utils.Outputable+#elif MIN_VERSION_ghc(9,2,0) import qualified GHC.Parser.Errors.Ppr as ParserErrorPpr-import GHC.Driver.Config (initParserOpts) import GHC.Parser.Annotation (LocatedA) #endif +#if MIN_VERSION_ghc(9,4,0)+import GHC.Driver.Config.Parser (initParserOpts)+#elif MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Config (initParserOpts)+#endif+ #if MIN_VERSION_ghc(9,0,0) import GHC.Parser.PostProcess import qualified GHC.Types.SrcLoc as SrcLoc@@ -64,6 +73,7 @@ #else parseExp = parseExpWithExts [ TypeApplications+ , OverloadedLabels ] #endif @@ -89,8 +99,14 @@ expr {- ORMOLU_DISABLE #-}-#if MIN_VERSION_ghc(9,2,0)- -- TODO messages?+#if MIN_VERSION_ghc(9,4,0)+ PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} ->+ let+ err = renderWithContext defaultSDocContext (ppr errorMessages)+ line = SrcLoc.srcLocLine srcLoc+ col = SrcLoc.srcLocCol srcLoc+ in Left (line, col, err)+#elif MIN_VERSION_ghc(9,2,0) PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} -> let psErrToString e = show $ ParserErrorPpr.pprError e
src/Language/Haskell/Meta/Settings.hs view
@@ -156,6 +156,10 @@ platformWordSize=8 , platformOS=OSUnknown #endif++#if MIN_VERSION_ghc(9, 4, 0)+ , platformHasLibm = False+#endif , platformUnregisterised=True } #if MIN_VERSION_ghc(9, 2, 0)
src/Language/Haskell/Meta/Translate.hs view
@@ -41,9 +41,9 @@ import GHC.Utils.Outputable (ppr) import GHC.Types.Basic (Boxity(..)) import GHC.Types.SourceText (il_value, rationalFromFractionalLit)-import GHC.Driver.Ppr (showSDocDebug)+import GHC.Driver.Ppr (showSDoc) #else-import GHC.Utils.Outputable (ppr, showSDocDebug)+import GHC.Utils.Outputable (ppr, showSDoc) import GHC.Types.Basic (il_value, fl_value, Boxity(..)) #endif import GHC.Driver.Session (DynFlags, xopt_set, defaultDynFlags)@@ -53,7 +53,7 @@ import Name import RdrName import FastString-import Outputable (ppr, showSDocDebug)+import Outputable (ppr, showSDoc) import BasicTypes (il_value, fl_value, Boxity(..)) import DynFlags (DynFlags, xopt_set, defaultDynFlags) import qualified Module@@ -104,7 +104,7 @@ in if isRdrTyVar n' then TH.VarT (toName n') else TH.ConT (toName n')-toType t = todo "toType" (showSDocDebug (Settings.baseDynFlags []) . ppr $ t)+toType t = todo "toType" (showSDoc(Settings.baseDynFlags []) . ppr $ t) toName :: RdrName -> TH.Name toName n = case n of@@ -118,7 +118,7 @@ toPat :: DynFlags -> Pat.Pat GhcPs -> TH.Pat toPat _dynFlags (Pat.VarPat _ (unLoc -> name)) = TH.VarP (toName name)-toPat dynFlags p = todo "toPat" (showSDocDebug dynFlags . ppr $ p)+toPat dynFlags p = todo "toPat" (showSDoc dynFlags . ppr $ p) toExp :: DynFlags -> Expr.HsExpr GhcPs -> TH.Exp toExp _ (Expr.HsVar _ n) =@@ -201,7 +201,11 @@ #endif -- toExp (Expr.List _ xs) = TH.ListE (fmap toExp xs)+#if MIN_VERSION_ghc(9, 4, 0)+toExp d (Expr.HsPar _ _ e _)+#else toExp d (Expr.HsPar _ e)+#endif = TH.ParensE (toExp d . unLoc $ e) toExp d (Expr.SectionL _ (unLoc -> a) (unLoc -> b))@@ -233,9 +237,23 @@ (FromTo a b) -> TH.FromToR (toExp d $ unLoc a) (toExp d $ unLoc b) (FromThenTo a b c) -> TH.FromThenToR (toExp d $ unLoc a) (toExp d $ unLoc b) (toExp d $ unLoc c) -#if MIN_VERSION_ghc(9, 2, 0)+#if MIN_VERSION_ghc(9, 4, 0) toExp _ (Expr.HsProjection _ locatedFields) = let+ extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+ extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+ in+ TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)++toExp d (Expr.HsGetField _ expr locatedField) =+ let+ extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+ extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+ in+ TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#elif MIN_VERSION_ghc(9, 2, 0)+toExp _ (Expr.HsProjection _ locatedFields) =+ let extractFieldLabel (HsFieldLabel _ locatedStr) = locatedStr extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..." in@@ -247,11 +265,16 @@ extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..." in TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#endif ++#if MIN_VERSION_ghc(9, 2, 0) toExp _ (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#else+toExp _ (Expr.HsOverLabel _ _ fastString) = TH.LabelE (unpackFS fastString) #endif -toExp dynFlags e = todo "toExp" (showSDocDebug dynFlags . ppr $ e)+toExp dynFlags e = todo "toExp" (showSDoc dynFlags . ppr $ e) todo :: (HasCallStack, Show e) => String -> e -> a todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show thing]
test/Main.hs view
@@ -23,12 +23,12 @@ let Right exp = parseExp "(.b.c.d)" let Just list = nonEmpty ["b", "c", "d"] exp `shouldBe` TH.ProjectionE list+#endif describe "Overloaded labels" $ do it "parses labels" $ do let Right exp = parseExp "#name" exp `shouldBe` TH.LabelE "name"-#endif describe "Type application" $ do it "parses application" $ do