ghc-hs-meta (empty) → 0.1.0.0
raw patch · 9 files changed
+773/−0 lines, 9 filesdep +basedep +bytestringdep +ghc
Dependencies added: base, bytestring, ghc, ghc-boot, ghc-hs-meta, hspec, template-haskell
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- LICENSE-PyF +30/−0
- README.md +25/−0
- ghc-hs-meta.cabal +55/−0
- src/Language/Haskell/Meta/Parse.hs +146/−0
- src/Language/Haskell/Meta/Settings.hs +179/−0
- src/Language/Haskell/Meta/Translate.hs +263/−0
- test/Main.hs +42/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Zachary Wood++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 Guillaume Bouchard 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.
+ LICENSE-PyF view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Guillaume Bouchard++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 Guillaume Bouchard 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,25 @@+# ghc-hs-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.++## Usage++Pass a String containing Haskell source code to `parseExp`.+Example from the tests:++```haskell+case parseExp "a @b" of+ Right exp -> exp `shouldBe` TH.AppTypeE (TH.VarE (TH.mkName "a")) (TH.VarT (TH.mkName "b"))+ Left (_, _, errMsg) -> error errMsg+```++See Hackage documentation for more documentation.++## Thank you, PyF++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!++The original license for PyF can be found in the `LICENSE-PyF` file included in this repository.
+ ghc-hs-meta.cabal view
@@ -0,0 +1,55 @@+cabal-version: 2.4++name: ghc-hs-meta+version: 0.1.0.0+build-type: Simple+author: Zachary Wood+maintainer: zac.wood@hey.com+license: BSD-3-Clause+license-files: LICENSE LICENSE-PyF+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++extra-source-files: CHANGELOG.md README.md++library+ exposed-modules:+ Language.Haskell.Meta.Parse+ Language.Haskell.Meta.Settings+ Language.Haskell.Meta.Translate+ hs-source-dirs:+ src+ default-extensions:+ TemplateHaskell+ 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+ , bytestring >= 0.10 && < 0.12+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ default-language: Haskell2010+ default-extensions:+ TemplateHaskell+ hs-source-dirs:+ test+ build-depends:+ base+ , template-haskell+ , ghc+ , ghc-boot+ , hspec+ , bytestring+ , ghc-hs-meta++source-repository head+ type: git+ location: https://github.com/zacwood9/ghc-hs-meta
+ src/Language/Haskell/Meta/Parse.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++-- | 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)+import qualified GHC.Parser.Errors.Ppr as ParserErrorPpr+import GHC.Driver.Config (initParserOpts)+import GHC.Parser.Annotation (LocatedA)+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Parser.PostProcess+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Driver.Session+import GHC.Data.StringBuffer+import GHC.Parser.Lexer+import qualified GHC.Parser.Lexer as Lexer+import qualified GHC.Parser as Parser+import GHC.Data.FastString+import GHC.Types.SrcLoc+#else+import qualified SrcLoc+import DynFlags (DynFlags)+import Lexer (ParseResult (..), PState (..))+import StringBuffer+import Lexer+import qualified Parser+import FastString+import SrcLoc+import RdrName+import RdrHsSyn (runECP_P)+#endif++import GHC.Hs.Extension (GhcPs)++-- @HsExpr@ is available from GHC.Hs.Expr in all versions we support.+-- However, the goal of GHC is to split HsExpr into its own package, under+-- the namespace Language.Haskell.Syntax. The module split happened in 9.0,+-- but still in the ghc package.+#if MIN_VERSION_ghc(9,2,0)+import Language.Haskell.Syntax (HsExpr(..))+#else+import GHC.Hs.Expr (HsExpr(..))+#endif++import Language.Haskell.TH (Extension(..))+import qualified Language.Haskell.TH.Syntax as TH++import qualified Language.Haskell.Meta.Settings as Settings+import Language.Haskell.Meta.Translate (toExp)++-- | Parse a Haskell expression from source code into a Template Haskell expression.+-- See @parseExpWithExts@ or @parseExpWithFlags@ for customizing with additional extensions and settings.+parseExp :: String -> Either (Int, Int, String) TH.Exp+#if MIN_VERSION_ghc(9,2,0)+parseExp = parseExpWithExts+ [ TypeApplications+ , OverloadedRecordDot+ , OverloadedLabels+ , OverloadedRecordUpdate+ ]+#else+parseExp = parseExpWithExts+ [ TypeApplications+ ]+#endif++-- | Parse a Haskell expression from source code into a Template Haskell expression+-- using a given set of GHC extensions.+parseExpWithExts :: [Extension] -> String -> Either (Int, Int, String) TH.Exp+parseExpWithExts exts = parseExpWithFlags (Settings.baseDynFlags exts)++-- | Parse a Haskell expression from source code into a Template Haskell expression+-- using a given set of GHC DynFlags.+parseExpWithFlags :: DynFlags -> String -> Either (Int, Int, String) TH.Exp+parseExpWithFlags flags expStr = do+ hsExpr <- parseHsExpr flags expStr+ pure (toExp flags hsExpr)++-- | Run the GHC parser to parse a Haskell expression into a @HsExpr@.+parseHsExpr :: DynFlags -> String -> Either (Int, Int, String) (HsExpr GhcPs)+parseHsExpr dynFlags s =+ case runParser dynFlags s of+ POk _ locatedExpr ->+ let expr = SrcLoc.unLoc locatedExpr+ in Right+ expr++{- ORMOLU_DISABLE #-}+#if MIN_VERSION_ghc(9,2,0)+ -- TODO messages?+ PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} ->+ let+ psErrToString e = show $ ParserErrorPpr.pprError e+ err = concatMap psErrToString errorMessages+ -- err = concatMap show errorMessages+ line = SrcLoc.srcLocLine srcLoc+ col = SrcLoc.srcLocCol srcLoc+ in Left (line, col, err)+#else+#if MIN_VERSION_ghc(9,0,0)+ PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, messages=msgs} ->+#elif MIN_VERSION_ghc(8,10,0)+ PFailed PState{loc=srcLoc, messages=msgs} ->+#endif+ let -- TODO: do not ignore "warnMessages"+ -- I have no idea what they can be+ (_warnMessages, errorMessages) = msgs dynFlags+ err = concatMap show errorMessages+ line = SrcLoc.srcLocLine srcLoc+ col = SrcLoc.srcLocCol srcLoc+ in Left (line, col, err)+#endif++-- From Language.Haskell.GhclibParserEx.GHC.Parser++parse :: P a -> String -> DynFlags -> ParseResult a+parse p str flags =+ Lexer.unP p parseState+ where+ location = mkRealSrcLoc (mkFastString "<string>") 1 1+ strBuffer = stringToStringBuffer str+ parseState =+#if MIN_VERSION_ghc(9, 2, 0)+ initParserState (initParserOpts flags) strBuffer location+#else+ mkPState flags strBuffer location+#endif++#if MIN_VERSION_ghc(9, 2, 0)+runParser :: DynFlags -> String -> ParseResult (LocatedA (HsExpr GhcPs))+runParser flags str =+ case parse Parser.parseExpression str flags of+ POk s e -> unP (runPV (unECP e)) s+ PFailed ps -> PFailed ps+#elif MIN_VERSION_ghc(8, 10, 0)+runParser :: DynFlags -> String -> ParseResult (Located (HsExpr GhcPs))+runParser flags str =+ case parse Parser.parseExpression str flags of+ POk s e -> unP (runECP_P e) s+ PFailed ps -> PFailed ps+#else+parseExpression = parse Parser.parseExpression+#endif
+ src/Language/Haskell/Meta/Settings.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-missing-fields -Wno-name-shadowing -Wno-unused-imports #-}++-- | Settings needed for running the GHC Parser.+module Language.Haskell.Meta.Settings (baseDynFlags) where++{- ORMOLU_DISABLE -}++#if MIN_VERSION_ghc(9,0,0)+import GHC.Settings.Config+import GHC.Driver.Session+import GHC.Utils.Fingerprint+import GHC.Platform+import GHC.Settings+#elif MIN_VERSION_ghc(8, 10, 0)+import Config+import DynFlags+import Fingerprint+import GHC.Platform+import ToolSettings+#else+import Config+import DynFlags+import Fingerprint+import Platform+#endif++#if MIN_VERSION_ghc(8,10,0)+import GHC.Hs+#else+import HsSyn+#endif++#if MIN_VERSION_ghc(9, 2, 0)+import GHC.Driver.Config+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Parser.PostProcess+import GHC.Driver.Session+import GHC.Data.StringBuffer+import GHC.Parser.Lexer+import qualified GHC.Parser.Lexer as Lexer+import qualified GHC.Parser as Parser+import GHC.Data.FastString+import GHC.Types.SrcLoc+import GHC.Driver.Backpack.Syntax+import GHC.Unit.Info+import GHC.Types.Name.Reader+#else+import StringBuffer+import Lexer+import qualified Parser+import FastString+import SrcLoc+import RdrName+#endif++#if MIN_VERSION_ghc(9, 0, 0)+#else+import RdrHsSyn+#endif++import Data.Data hiding (Fixity)++#if MIN_VERSION_ghc(9,0,0)+import GHC.Hs++#if MIN_VERSION_ghc(9, 2, 0)+import GHC.Types.Fixity+import GHC.Types.SourceText+#else+import GHC.Types.Basic+#endif++import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SrcLoc+#elif MIN_VERSION_ghc(8, 10, 0)+import BasicTypes+import OccName+#else+import BasicTypes+import OccName+#endif++import qualified Language.Haskell.TH.Syntax as GhcTH+import Data.Maybe++fakeSettings :: Settings+fakeSettings = Settings+#if MIN_VERSION_ghc(9, 2, 0)+ { sGhcNameVersion=ghcNameVersion+ , sFileSettings=fileSettings+ , sTargetPlatform=platform+ , sPlatformMisc=platformMisc+ , sToolSettings=toolSettings+ }+#elif MIN_VERSION_ghc(8, 10, 0)+ { 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 MIN_VERSION_ghc(8, 10, 0)+ toolSettings = ToolSettings {+ toolSettings_opt_P_fingerprint=fingerprint0+ }+ fileSettings = FileSettings {}+ platformMisc = PlatformMisc {}+ ghcNameVersion =+ GhcNameVersion{ghcNameVersion_programName="ghc"+ ,ghcNameVersion_projectVersion=cProjectVersion+ }+#endif+ platform =+ Platform{+#if MIN_VERSION_ghc(9, 0, 0)+ -- It doesn't matter what values we write here as these fields are+ -- not referenced for our purposes. However the fields are strict+ -- so we must say something.+ platformByteOrder=LittleEndian+ , platformHasGnuNonexecStack=True+ , platformHasIdentDirective=False+ , platformHasSubsectionsViaSymbols=False+ , platformIsCrossCompiling=False+ , platformLeadingUnderscore=False+ , platformTablesNextToCode=False+#if MIN_VERSION_ghc(9, 2, 0)+ , platform_constants=platformConstants+#endif+ ,+#endif++#if MIN_VERSION_ghc(9, 2, 0)+ platformWordSize=PW8+ , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown}+#elif MIN_VERSION_ghc(8, 10, 0)+ platformWordSize=PW8+ , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown}+#else+ platformWordSize=8+ , platformOS=OSUnknown+#endif+ , platformUnregisterised=True+ }+#if MIN_VERSION_ghc(9, 2, 0)+ platformConstants = Nothing+#else+ platformConstants =+ PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}+#endif++#if MIN_VERSION_ghc(8, 10, 0)+fakeLlvmConfig :: LlvmConfig+fakeLlvmConfig = LlvmConfig [] []+#else+fakeLlvmConfig :: (LlvmTargets, LlvmPasses)+fakeLlvmConfig = ([], [])+#endif++baseDynFlags :: [GhcTH.Extension] -> DynFlags+baseDynFlags exts =+ let enable = GhcTH.TemplateHaskellQuotes : exts+ in foldl xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable
+ src/Language/Haskell/Meta/Translate.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Meta.Translate (toExp) where++#if MIN_VERSION_ghc(9,2,0)+import GHC.Hs.Type (HsWildCardBndrs (..), HsType (..), HsSigType(HsSig), sig_body)+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Hs.Type (HsWildCardBndrs (..), HsType (..), HsImplicitBndrs(HsIB), hsib_body)+#elif MIN_VERSION_ghc(8,10,0)+import GHC.Hs.Types (HsWildCardBndrs (..), HsType (..), HsImplicitBndrs (HsIB, hsib_body))+#else+import HsTypes (HsWildCardBndrs (..), HsType (..), HsImplicitBndrs (HsIB), hsib_body)+#endif++#if MIN_VERSION_ghc(8,10,0)+import GHC.Hs.Expr as Expr+import GHC.Hs.Extension as Ext+import GHC.Hs.Pat as Pat+import GHC.Hs.Lit+#else+import HsExpr as Expr+import HsExtension as Ext+import HsPat as Pat+import HsLit+#endif++import qualified Data.ByteString as B+import qualified Language.Haskell.TH.Syntax as GhcTH+import qualified Language.Haskell.TH.Syntax as TH++#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Data.FastString+#if MIN_VERSION_ghc(9,2,0)+import GHC.Utils.Outputable (ppr)+import GHC.Types.Basic (Boxity(..))+import GHC.Types.SourceText (il_value, rationalFromFractionalLit)+import GHC.Driver.Ppr (showSDocDebug)+#else+import GHC.Utils.Outputable (ppr, showSDocDebug)+import GHC.Types.Basic (il_value, fl_value, Boxity(..))+#endif+import GHC.Driver.Session (DynFlags, xopt_set, defaultDynFlags)+import qualified GHC.Unit.Module as Module+#else+import SrcLoc+import Name+import RdrName+import FastString+import Outputable (ppr, showSDocDebug)+import BasicTypes (il_value, fl_value, Boxity(..))+import DynFlags (DynFlags, xopt_set, defaultDynFlags)+import qualified Module+#endif++import GHC.Stack+import qualified Language.Haskell.Meta.Settings as Settings++import qualified Data.List.NonEmpty as NonEmpty++#if MIN_VERSION_ghc(9,2,0)+-- TODO: why this disapears in GHC >= 9.2?+fl_value = rationalFromFractionalLit+#endif++++-----------------------------++toLit :: HsLit GhcPs -> TH.Lit+toLit (HsChar _ c) = TH.CharL c+toLit (HsCharPrim _ c) = TH.CharPrimL c+toLit (HsString _ s) = TH.StringL (unpackFS s)+toLit (HsStringPrim _ s) = TH.StringPrimL (B.unpack s)+toLit (HsInt _ i) = TH.IntegerL (il_value i)+toLit (HsIntPrim _ i) = TH.IntPrimL i+toLit (HsWordPrim _ i) = TH.WordPrimL i+toLit (HsInt64Prim _ i) = TH.IntegerL i+toLit (HsWord64Prim _ i) = TH.WordPrimL i+toLit (HsInteger _ i _) = TH.IntegerL i+toLit (HsRat _ f _) = TH.FloatPrimL (fl_value f)+toLit (HsFloatPrim _ f) = TH.FloatPrimL (fl_value f)+toLit (HsDoublePrim _ f) = TH.DoublePrimL (fl_value f)++#if !MIN_VERSION_ghc(9,0,0)+toLit (XLit _) = noTH "toLit" "XLit"+#endif++toLit' :: OverLitVal -> TH.Lit+toLit' (HsIntegral i) = TH.IntegerL (il_value i)+toLit' (HsFractional f) = TH.RationalL (fl_value f)+toLit' (HsIsString _ fs) = TH.StringL (unpackFS fs)++toType :: HsType GhcPs -> TH.Type+toType (HsWildCardTy _) = TH.WildCardT+toType (HsTyVar _ _ n) =+ let n' = unLoc n+ in if isRdrTyVar n'+ then TH.VarT (toName n')+ else TH.ConT (toName n')+toType t = todo "toType" (showSDocDebug (Settings.baseDynFlags []) . ppr $ t)++toName :: RdrName -> TH.Name+toName n = case n of+ (Unqual o) -> TH.mkName (occNameString o)+ (Qual m o) -> TH.mkName (Module.moduleNameString m <> "." <> occNameString o)+ (Orig _ _) -> error "orig"+ (Exact _) -> error "exact"++toFieldExp :: a+toFieldExp = undefined++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)++toExp :: DynFlags -> Expr.HsExpr GhcPs -> TH.Exp+toExp _ (Expr.HsVar _ n) =+ let n' = unLoc n+ in if isRdrDataCon n'+ then TH.ConE (toName n')+ else TH.VarE (toName n')++#if MIN_VERSION_ghc(9,0,0)+toExp _ (Expr.HsUnboundVar _ n) = TH.UnboundVarE (TH.mkName . occNameString $ n)+#else+toExp _ (Expr.HsUnboundVar _ n) = TH.UnboundVarE (TH.mkName . occNameString . Expr.unboundVarOcc $ n)+#endif++toExp _ Expr.HsIPVar {}+ = noTH "toExp" "HsIPVar"++toExp _ (Expr.HsLit _ l)+ = TH.LitE (toLit l)++toExp _ (Expr.HsOverLit _ OverLit {ol_val})+ = TH.LitE (toLit' ol_val)++toExp d (Expr.HsApp _ e1 e2)+ = TH.AppE (toExp d . unLoc $ e1) (toExp d . unLoc $ e2)++#if MIN_VERSION_ghc(9,2,0)+toExp d (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+toExp d (Expr.ExprWithTySig _ e HsWC{hswc_body=unLoc -> HsSig{sig_body}}) = TH.SigE (toExp d . unLoc $ e) (toType . unLoc $ sig_body)+#elif MIN_VERSION_ghc(8,8,0)+toExp d (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+toExp d (Expr.ExprWithTySig _ e HsWC{hswc_body=HsIB{hsib_body}}) = TH.SigE (toExp d . unLoc $ e) (toType . unLoc $ hsib_body)+#else+toExp d (Expr.HsAppType HsWC {hswc_body} e) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+#endif++toExp d (Expr.OpApp _ e1 o e2)+ = TH.UInfixE (toExp d . unLoc $ e1) (toExp d . unLoc $ o) (toExp d . unLoc $ e2)++toExp d (Expr.NegApp _ e _)+ = TH.AppE (TH.VarE 'negate) (toExp d . unLoc $ e)++-- NOTE: for lambda, there is only one match+toExp d (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))+ = TH.LamE (fmap (toPat d) ps) (toExp d e)++-- toExp (Expr.Let _ bs e) = TH.LetE (toDecs bs) (toExp e)+--+#if MIN_VERSION_ghc(9, 0, 0)+toExp d (Expr.HsIf _ a b c) = TH.CondE (toExp d (unLoc a)) (toExp d (unLoc b)) (toExp d (unLoc c))+#else+toExp d (Expr.HsIf _ _ a b c) = TH.CondE (toExp d (unLoc a)) (toExp d (unLoc b)) (toExp d (unLoc c))+#endif++-- toExp (Expr.MultiIf _ ifs) = TH.MultiIfE (map toGuard ifs)+-- toExp (Expr.Case _ e alts) = TH.CaseE (toExp e) (map toMatch alts)+-- toExp (Expr.Do _ ss) = TH.DoE (map toStmt ss)+-- toExp e@Expr.MDo{} = noTH "toExp" e+--+#if MIN_VERSION_ghc(9, 2, 0)+toExp d (Expr.ExplicitTuple _ args boxity) = ctor tupArgs+#else+toExp d (Expr.ExplicitTuple _ (map unLoc -> args) boxity) = ctor tupArgs+#endif+ where+ toTupArg (Expr.Present _ e) = Just $ unLoc e+ toTupArg (Expr.Missing _) = Nothing+ toTupArg _ = error "impossible case"++ ctor = case boxity of+ Boxed -> TH.TupE+ Unboxed -> TH.UnboxedTupE++#if MIN_VERSION_ghc(8,10,0)+ tupArgs = fmap ((fmap (toExp d)) . toTupArg) args+#else+ tupArgs = case traverse toTupArg args of+ Nothing -> error "Tuple section are not supported by template haskell < 8.10"+ Just args -> fmap (toExp d) args+#endif++-- toExp (Expr.List _ xs) = TH.ListE (fmap toExp xs)+toExp d (Expr.HsPar _ e)+ = TH.ParensE (toExp d . unLoc $ e)++toExp d (Expr.SectionL _ (unLoc -> a) (unLoc -> b))+ = TH.InfixE (Just . toExp d $ a) (toExp d b) Nothing++toExp d (Expr.SectionR _ (unLoc -> a) (unLoc -> b))+ = TH.InfixE Nothing (toExp d a) (Just . toExp d $ b)++toExp _ (Expr.RecordCon _ name HsRecFields {rec_flds})+ = TH.RecConE (toName . unLoc $ name) (fmap toFieldExp rec_flds)++-- toExp (Expr.RecUpdate _ e xs) = TH.RecUpdE (toExp e) (fmap toFieldExp xs)+-- toExp (Expr.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]+-- where+-- convert (Expr.QualStmt _ st) = toStmt st+-- convert s = noTH "toExp ListComp" s+-- toExp (Expr.ExpTypeSig _ e t) = TH.SigE (toExp e) (toType t)+--+#if MIN_VERSION_ghc(9, 2, 0)+toExp d (Expr.ExplicitList _ (map unLoc -> args)) = TH.ListE (map (toExp d) args)+#else+toExp d (Expr.ExplicitList _ _ (map unLoc -> args)) = TH.ListE (map (toExp d) args)+#endif++toExp d (Expr.ArithSeq _ _ e)+ = TH.ArithSeqE $ case e of+ (From a) -> TH.FromR (toExp d $ unLoc a)+ (FromThen a b) -> TH.FromThenR (toExp d $ unLoc a) (toExp d $ unLoc b)+ (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)+toExp _ (Expr.HsProjection _ locatedFields) =+ let+ extractFieldLabel (HsFieldLabel _ 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 (HsFieldLabel _ locatedStr) = locatedStr+ extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+ in+ TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)++toExp _ (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#endif++toExp dynFlags e = todo "toExp" (showSDocDebug dynFlags . ppr $ e)++todo :: (HasCallStack, Show e) => String -> e -> a+todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show thing]++noTH :: (HasCallStack, Show e) => String -> e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun, ": no TemplateHaskell for: ", show thing]++moduleName :: String+moduleName = "Language.Haskell.Meta.Translate"
+ test/Main.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}++module Main where++import Data.List.NonEmpty (nonEmpty)+import Language.Haskell.Meta.Parse+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import Test.Hspec ( hspec, describe, it, shouldBe, Spec )++spec :: Spec+spec = do+#if MIN_VERSION_ghc(9,2,0)+ describe "Record dot syntax" $ do+ it "parses access" $ do+ let Right exp = parseExp "a.b"+ exp `shouldBe` TH.GetFieldE (TH.VarE (TH.mkName "a")) "b"+ it "parses single projection" $ do+ let Right exp = parseExp "(.b)"+ let Just list = nonEmpty ["b"]+ exp `shouldBe` TH.ProjectionE list+ it "parses multi projection" $ do+ let Right exp = parseExp "(.b.c.d)"+ let Just list = nonEmpty ["b", "c", "d"]+ exp `shouldBe` TH.ProjectionE list++ 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+ let Right exp = parseExp "a @b"+ exp `shouldBe` TH.AppTypeE (TH.VarE (TH.mkName "a")) (TH.VarT (TH.mkName "b"))++ describe "infix operators" $ do+ it "parses infix operator" $ do+ let Right exp = parseExp "a |> b"+ exp `shouldBe` TH.UInfixE (TH.VarE (TH.mkName "a")) (TH.VarE (TH.mkName "|>")) (TH.VarE (TH.mkName "b"))+main = hspec spec