mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Add support for GHC 9.2 (#92)
* [prefactor] Split up NoExtField/Placeholder helpers * [prefactor] Use smart constructors * Use nightly resolver * Support GHC 9.2 * Fix for GHC 9.2 * Fix ghc-show-ast * Readd GHC 9.0 to CI
This commit is contained in:
parent
b5b501745d
commit
f6b9130d8f
@ -61,7 +61,11 @@ workflows:
|
||||
- build:
|
||||
name: build-ghc-9.0
|
||||
stack_yaml: stack-9.0.yaml
|
||||
- build:
|
||||
name: build-ghc-9.2
|
||||
stack_yaml: stack-9.2.yaml
|
||||
- build-success:
|
||||
requires:
|
||||
- build
|
||||
- build-ghc-9.0
|
||||
- build-ghc-9.2
|
||||
|
@ -13,6 +13,13 @@ import Data.Typeable (cast)
|
||||
import System.Environment (getArgs)
|
||||
import Text.PrettyPrint
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import qualified GHC.Driver.Errors as Error
|
||||
import qualified GHC.Parser.Errors.Ppr as Error
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
import qualified GHC.Utils.Error as Error
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,1)
|
||||
import GHC.Data.FastString
|
||||
import GHC.Types.Name
|
||||
@ -45,7 +52,6 @@ import qualified GHC.Parser as Parser
|
||||
import qualified GHC.Types.SrcLoc as GHC
|
||||
import qualified GHC.Data.StringBuffer as GHC
|
||||
import GHC.Paths (libdir)
|
||||
import qualified GHC.Utils.Error as Error
|
||||
import GHC.Driver.Monad (liftIO)
|
||||
#else
|
||||
import FastString
|
||||
@ -107,10 +113,36 @@ parseModule f = GHC.runGhc (Just libdir) $ do
|
||||
contents <- GHC.liftIO $ GHC.stringToStringBuffer <$> readFile f
|
||||
let options = GHC.getOptions dflags contents f
|
||||
(dflags', _, _) <- GHC.parseDynamicFilePragma dflags options
|
||||
let state = GHC.mkPState dflags' contents (GHC.mkRealSrcLoc (GHC.fsLit f) 1 1)
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
let state =
|
||||
GHC.initParserState
|
||||
( GHC.mkParserOpts
|
||||
(GHC.warningFlags dflags')
|
||||
(GHC.extensionFlags dflags')
|
||||
(GHC.safeImportsOn dflags')
|
||||
(GHC.gopt GHC.Opt_Haddock dflags')
|
||||
(GHC.gopt GHC.Opt_KeepRawTokenStream dflags')
|
||||
True
|
||||
)
|
||||
#else
|
||||
let state =
|
||||
GHC.mkPState
|
||||
dflags'
|
||||
#endif
|
||||
contents
|
||||
(GHC.mkRealSrcLoc (GHC.fsLit f) 1 1)
|
||||
|
||||
case GHC.unP Parser.parseModule state of
|
||||
GHC.POk _state m -> return $ GHC.unLoc m
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
GHC.PFailed s -> do
|
||||
logger <- GHC.getLogger
|
||||
liftIO $ do
|
||||
let errors = Error.pprError <$> GHC.getErrorMessages s
|
||||
Error.printBagOfErrors logger dflags errors
|
||||
exitFailure
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
GHC.PFailed s -> liftIO $ do
|
||||
let (_warnings, errors) = GHC.messages s dflags
|
||||
Error.printBagOfErrors dflags errors
|
||||
|
@ -61,7 +61,7 @@ library
|
||||
TypeSynonymInstances
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, ghc >=8.4 && <9.2
|
||||
, ghc >=8.4 && <9.3
|
||||
if impl(ghc<8.10)
|
||||
other-modules:
|
||||
GHC.Hs
|
||||
@ -110,7 +110,7 @@ test-suite name_test
|
||||
build-depends:
|
||||
QuickCheck >=2.10 && <2.15
|
||||
, base >=4.7 && <5
|
||||
, ghc >=8.4 && <9.2
|
||||
, ghc >=8.4 && <9.3
|
||||
, ghc-source-gen
|
||||
, tasty >=1.0 && <1.5
|
||||
, tasty-hunit ==0.10.*
|
||||
@ -131,7 +131,7 @@ test-suite pprint_examples
|
||||
TypeSynonymInstances
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, ghc >=8.4 && <9.2
|
||||
, ghc >=8.4 && <9.3
|
||||
, ghc-paths ==0.1.*
|
||||
, ghc-source-gen
|
||||
, tasty >=1.0 && <1.5
|
||||
@ -157,7 +157,7 @@ test-suite pprint_test
|
||||
TypeSynonymInstances
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, ghc >=8.4 && <9.2
|
||||
, ghc >=8.4 && <9.3
|
||||
, ghc-paths ==0.1.*
|
||||
, ghc-source-gen
|
||||
, tasty >=1.0 && <1.5
|
||||
|
@ -30,7 +30,7 @@ description: |
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- ghc >= 8.4 && < 9.2
|
||||
- ghc >= 8.4 && < 9.3
|
||||
|
||||
default-extensions:
|
||||
- DataKinds
|
||||
|
@ -46,7 +46,11 @@ module GHC.SourceGen.Binds
|
||||
, (<--)
|
||||
) where
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC (LexicalFixity(..))
|
||||
#else
|
||||
import GHC.Types.Basic (LexicalFixity(..))
|
||||
#endif
|
||||
import Data.Bool (bool)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import GHC.Hs.Binds
|
||||
@ -69,7 +73,7 @@ import GHC.SourceGen.Type.Internal (sigWcType)
|
||||
-- > typeSigs ["f", "g"] (var "A")
|
||||
typeSigs :: HasValBind t => [OccNameStr] -> HsType' -> t
|
||||
typeSigs names t =
|
||||
sigB $ noExt TypeSig (map (typeRdrName . unqual) names)
|
||||
sigB $ withEpAnnNotUsed TypeSig (map (typeRdrName . unqual) names)
|
||||
$ sigWcType t
|
||||
|
||||
-- | Declares the type of a single function or value.
|
||||
@ -184,7 +188,7 @@ patBindGRHSs p g =
|
||||
bindB
|
||||
$ withPlaceHolder
|
||||
(withPlaceHolder
|
||||
(noExt PatBind (builtPat p) (mkGRHSs g)))
|
||||
(withEpAnnNotUsed PatBind (builtPat p) (mkGRHSs g)))
|
||||
$ ([],[])
|
||||
|
||||
-- | Defines a pattern binding without any guards.
|
||||
@ -277,7 +281,7 @@ guard s = guards [stmt s]
|
||||
-- > =====
|
||||
-- > guards [conP "Just" (bvar "x") <-- var "y", bvar "x"] unit
|
||||
guards :: [Stmt'] -> HsExpr' -> GuardedExpr
|
||||
guards stmts e = noExt GRHS (map builtLoc stmts) (builtLoc e)
|
||||
guards stmts e = withEpAnnNotUsed GRHS (map mkLocated stmts) (mkLocated e)
|
||||
|
||||
-- | An expression statement. May be used in a do expression (with 'do'') or in a
|
||||
-- match (with 'guard').
|
||||
@ -286,7 +290,7 @@ guards stmts e = noExt GRHS (map builtLoc stmts) (builtLoc e)
|
||||
stmt :: HsExpr' -> Stmt'
|
||||
-- For now, don't worry about rebindable syntax.
|
||||
stmt e =
|
||||
withPlaceHolder $ noExt BodyStmt (builtLoc e) noSyntaxExpr noSyntaxExpr
|
||||
withPlaceHolder $ noExt BodyStmt (mkLocated e) noSyntaxExpr noSyntaxExpr
|
||||
|
||||
-- | A statement that binds a pattern.
|
||||
--
|
||||
@ -294,7 +298,7 @@ stmt e =
|
||||
-- > =====
|
||||
-- > bvar "x" <-- var "act"
|
||||
(<--) :: Pat' -> HsExpr' -> Stmt'
|
||||
p <-- e = withPlaceHolder $ noExt BindStmt (builtPat p) (builtLoc e)
|
||||
p <-- e = withPlaceHolder $ withEpAnnNotUsed BindStmt (builtPat p) (mkLocated e)
|
||||
#if !MIN_VERSION_ghc(9,0,0)
|
||||
noSyntaxExpr noSyntaxExpr
|
||||
#endif
|
||||
|
@ -10,11 +10,9 @@ module GHC.SourceGen.Binds.Internal where
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (Origin(Generated))
|
||||
import GHC.Data.Bag (listToBag)
|
||||
import GHC.Types.SrcLoc (Located)
|
||||
#else
|
||||
import BasicTypes (Origin(Generated))
|
||||
import Bag (listToBag)
|
||||
import SrcLoc (Located)
|
||||
#endif
|
||||
import GHC.Hs.Binds
|
||||
import GHC.Hs.Decls
|
||||
@ -40,14 +38,14 @@ valBinds :: [RawValBind] -> HsLocalBinds'
|
||||
-- This case prevents GHC from printing an empty "where" clause:
|
||||
valBinds [] = noExt EmptyLocalBinds
|
||||
valBinds vbs =
|
||||
noExt HsValBinds
|
||||
withEpAnnNotUsed HsValBinds
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
$ noExt ValBinds
|
||||
$ withNoAnnSortKey ValBinds
|
||||
#else
|
||||
$ noExt ValBindsIn
|
||||
#endif
|
||||
(listToBag $ map builtLoc binds)
|
||||
(map builtLoc sigs)
|
||||
(listToBag $ map mkLocated binds)
|
||||
(map mkLocated sigs)
|
||||
where
|
||||
sigs = [s | SigV s <- vbs]
|
||||
binds = [b | BindV b <- vbs]
|
||||
@ -83,30 +81,36 @@ data RawGRHSs = RawGRHSs
|
||||
, rawGRHSWhere :: [RawValBind]
|
||||
}
|
||||
|
||||
matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' (Located HsExpr')
|
||||
matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr'
|
||||
matchGroup context matches =
|
||||
noExt MG (builtLoc $ map (builtLoc . mkMatch) matches)
|
||||
noExt MG (mkLocated $ map (mkLocated . mkMatch) matches)
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
[] PlaceHolder
|
||||
#endif
|
||||
Generated
|
||||
where
|
||||
mkMatch :: RawMatch -> Match' (Located HsExpr')
|
||||
mkMatch r = noExt Match context
|
||||
mkMatch :: RawMatch -> Match' LHsExpr'
|
||||
mkMatch r = withEpAnnNotUsed Match context
|
||||
(map builtPat $ map parenthesize $ rawMatchPats r)
|
||||
(mkGRHSs $ rawMatchGRHSs r)
|
||||
|
||||
mkGRHSs :: RawGRHSs -> GRHSs' (Located HsExpr')
|
||||
mkGRHSs g = noExt GRHSs
|
||||
mkGRHSs :: RawGRHSs -> GRHSs' LHsExpr'
|
||||
mkGRHSs g = withEmptyEpAnnComments GRHSs
|
||||
(map builtLoc $ rawGRHSs g)
|
||||
(builtLoc $ valBinds $ rawGRHSWhere g)
|
||||
(fromLocalBinds $ valBinds $ rawGRHSWhere g)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
fromLocalBinds = id
|
||||
#else
|
||||
fromLocalBinds = builtLoc
|
||||
#endif
|
||||
|
||||
-- | An expression with a single guard.
|
||||
--
|
||||
-- For example:
|
||||
--
|
||||
-- > | otherwise = ()
|
||||
type GuardedExpr = GRHS' (Located HsExpr')
|
||||
type GuardedExpr = GRHS' LHsExpr'
|
||||
|
||||
-- | Syntax types which can declare/define functions. For example:
|
||||
-- declarations, or the body of a class declaration or class instance.
|
||||
|
@ -5,6 +5,8 @@
|
||||
-- https://developers.google.com/open-source/licenses/bsd
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | This module provides combinators for constructing Haskell declarations.
|
||||
module GHC.SourceGen.Decl
|
||||
( HsDecl'
|
||||
@ -50,17 +52,17 @@ module GHC.SourceGen.Decl
|
||||
) where
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (LexicalFixity(Prefix))
|
||||
import GHC (LexicalFixity(Prefix))
|
||||
import GHC.Data.Bag (listToBag)
|
||||
import GHC.Types.SrcLoc (Located, LayoutInfo(..))
|
||||
import GHC.Types.SrcLoc (LayoutInfo(..))
|
||||
#else
|
||||
import BasicTypes (LexicalFixity(Prefix))
|
||||
import Bag (listToBag)
|
||||
import SrcLoc (Located)
|
||||
#endif
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
import BasicTypes (DerivStrategy(..))
|
||||
#endif
|
||||
import GHC (GhcPs)
|
||||
import GHC.Hs.Binds
|
||||
import GHC.Hs.Decls
|
||||
|
||||
@ -68,9 +70,15 @@ import GHC.Hs.Type
|
||||
( ConDeclField(..)
|
||||
, FieldOcc(..)
|
||||
, HsConDetails(..)
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
, HsImplicitBndrs (..)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, HsOuterTyVarBndrs (..)
|
||||
#endif
|
||||
, HsSrcBang(..)
|
||||
, HsType(..)
|
||||
, LHsType
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
, HsWildCardBndrs (..)
|
||||
#endif
|
||||
@ -84,7 +92,9 @@ import GHC.Hs.Type
|
||||
#endif
|
||||
)
|
||||
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Parser.Annotation (AnnSortKey(..), EpAnn(..))
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
import GHC.Hs.Extension (NoExtField(NoExtField))
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
import GHC.Hs.Extension (NoExt(NoExt))
|
||||
@ -163,8 +173,10 @@ class'
|
||||
-> HsDecl'
|
||||
class' context name vars decls
|
||||
= noExt TyClD $ ClassDecl
|
||||
{ tcdCtxt = builtLoc $ map builtLoc context
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
{ tcdCtxt = toHsContext $ mkLocated $ map mkLocated context
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, tcdCExt = (EpAnnNotUsed, NoAnnSortKey, NoLayoutInfo)
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
, tcdCExt = NoLayoutInfo
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
, tcdCExt = NoExtField
|
||||
@ -176,16 +188,27 @@ class' context name vars decls
|
||||
, tcdLName = typeRdrName $ unqual name
|
||||
, tcdTyVars = mkQTyVars vars
|
||||
, tcdFixity = Prefix
|
||||
, tcdFDs = [ builtLoc (map typeRdrName xs, map typeRdrName ys)
|
||||
, tcdFDs = [ mkLocated $ funDep' (map typeRdrName xs) (map typeRdrName ys)
|
||||
| ClassFunDep xs ys <- decls
|
||||
]
|
||||
, tcdSigs = [builtLoc sig | ClassSig sig <- decls]
|
||||
, tcdSigs = [mkLocated sig | ClassSig sig <- decls]
|
||||
, tcdMeths =
|
||||
listToBag [builtLoc bind | ClassDefaultMethod bind <- decls]
|
||||
listToBag [mkLocated bind | ClassDefaultMethod bind <- decls]
|
||||
, tcdATs = [] -- Associated types
|
||||
, tcdATDefs = [] -- Associated type defaults
|
||||
, tcdDocs = [] -- Haddocks
|
||||
}
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
funDep' = withEpAnnNotUsed FunDep
|
||||
#else
|
||||
funDep' = (,)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
toHsContext = Just
|
||||
#else
|
||||
toHsContext = id
|
||||
#endif
|
||||
|
||||
-- | A definition that can appear in the body of an @instance@ declaration.
|
||||
--
|
||||
@ -217,14 +240,16 @@ instance HasValBind RawInstDecl where
|
||||
instance' :: HsType' -> [RawInstDecl] -> HsDecl'
|
||||
instance' ty decls = noExt InstD $ noExt ClsInstD $ ClsInstDecl
|
||||
{ cid_poly_ty = sigType ty
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, cid_ext = (EpAnnNotUsed, NoAnnSortKey)
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
, cid_ext = NoExtField
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
, cid_ext = NoExt
|
||||
#endif
|
||||
, cid_binds = listToBag [builtLoc b | InstBind b <- decls]
|
||||
, cid_sigs = [builtLoc sig | InstSig sig <- decls]
|
||||
, cid_tyfam_insts = [builtLoc $ t | InstTyFam t <- decls]
|
||||
, cid_binds = listToBag [mkLocated b | InstBind b <- decls]
|
||||
, cid_sigs = [mkLocated sig | InstSig sig <- decls]
|
||||
, cid_tyfam_insts = [mkLocated $ t | InstTyFam t <- decls]
|
||||
, cid_datafam_insts = []
|
||||
, cid_overlap_mode = Nothing
|
||||
}
|
||||
@ -248,17 +273,31 @@ instance HasTyFamInst RawInstDecl where
|
||||
-- > tyFamInst "Elt" [var "String"] (var "Char")
|
||||
tyFamInst :: HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t
|
||||
tyFamInst name params ty = tyFamInstD
|
||||
$ TyFamInstDecl
|
||||
$ implicitBndrs
|
||||
$ noExt FamEqn (typeRdrName name)
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
Nothing -- eqn binders
|
||||
(map (HsValArg . builtLoc) params)
|
||||
#else
|
||||
(map builtLoc params)
|
||||
#endif
|
||||
$ tyFamInstDecl
|
||||
$ famEqn
|
||||
(typeRdrName name)
|
||||
eqn_bndrs
|
||||
(map mkLocated params)
|
||||
Prefix
|
||||
(builtLoc ty)
|
||||
(mkLocated ty)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
tyFamInstDecl = withEpAnnNotUsed TyFamInstDecl
|
||||
#else
|
||||
tyFamInstDecl = TyFamInstDecl . withPlaceHolder . noExt (withPlaceHolder HsIB)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
famEqn tycon bndrs pats = withEpAnnNotUsed FamEqn tycon bndrs (map HsValArg pats)
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
famEqn tycon bndrs pats = noExt FamEqn tycon bndrs (map HsValArg pats)
|
||||
#else
|
||||
famEqn tycon _ = noExt FamEqn tycon
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
eqn_bndrs = noExt HsOuterImplicit
|
||||
#else
|
||||
eqn_bndrs = Nothing
|
||||
#endif
|
||||
|
||||
-- | Declares a type synonym.
|
||||
--
|
||||
@ -267,10 +306,10 @@ tyFamInst name params ty = tyFamInstD
|
||||
-- > type' "A" [bvar "a", bvar "b"] $ var "B" @@ var "b" @@ var "a"
|
||||
type' :: OccNameStr -> [HsTyVarBndr'] -> HsType' -> HsDecl'
|
||||
type' name vars t =
|
||||
noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName $ unqual name)
|
||||
noExt TyClD $ withPlaceHolder $ withEpAnnNotUsed SynDecl (typeRdrName $ unqual name)
|
||||
(mkQTyVars vars)
|
||||
Prefix
|
||||
(builtLoc t)
|
||||
(mkLocated t)
|
||||
|
||||
newOrDataType
|
||||
:: NewOrData
|
||||
@ -281,14 +320,26 @@ newOrDataType
|
||||
-> HsDecl'
|
||||
newOrDataType newOrData name vars conDecls derivs
|
||||
= noExt TyClD $ withPlaceHolder $ withPlaceHolder $
|
||||
noExt DataDecl (typeRdrName $ unqual name)
|
||||
withEpAnnNotUsed DataDecl (typeRdrName $ unqual name)
|
||||
(mkQTyVars vars)
|
||||
Prefix
|
||||
$ noExt HsDataDefn newOrData
|
||||
(builtLoc []) Nothing
|
||||
cxt
|
||||
Nothing
|
||||
(map builtLoc conDecls)
|
||||
(builtLoc $ map builtLoc derivs)
|
||||
Nothing
|
||||
(map mkLocated conDecls)
|
||||
(toHsDeriving $ map builtLoc derivs)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
cxt = Nothing
|
||||
#else
|
||||
cxt = builtLoc []
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
toHsDeriving = id
|
||||
#else
|
||||
toHsDeriving = mkLocated
|
||||
#endif
|
||||
|
||||
-- | A newtype declaration.
|
||||
--
|
||||
@ -321,7 +372,13 @@ data' = newOrDataType DataType
|
||||
-- > prefixCon "Foo" [field (var "a"), field (var "Int")]
|
||||
prefixCon :: OccNameStr -> [Field] -> ConDecl'
|
||||
prefixCon name fields = renderCon98Decl name
|
||||
$ PrefixCon $ map (hsUnrestricted . renderField) fields
|
||||
$ prefixCon' $ map (hsUnrestricted . renderField) fields
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
prefixCon' = PrefixCon []
|
||||
#else
|
||||
prefixCon' = PrefixCon
|
||||
#endif
|
||||
|
||||
-- | Declares a Haskell-98-style infix constructor for a data or type
|
||||
-- declaration.
|
||||
@ -341,10 +398,10 @@ infixCon f name f' = renderCon98Decl name
|
||||
-- > recordCon "A" [("x", var "B"), ("y", var "C")]
|
||||
recordCon :: OccNameStr -> [(OccNameStr, Field)] -> ConDecl'
|
||||
recordCon name fields = renderCon98Decl name
|
||||
$ RecCon $ builtLoc $ map mkLConDeclField fields
|
||||
$ RecCon $ mkLocated $ map mkLConDeclField fields
|
||||
where
|
||||
mkLConDeclField (n, f) =
|
||||
builtLoc $ noExt ConDeclField
|
||||
mkLocated $ withEpAnnNotUsed ConDeclField
|
||||
[builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName $ unqual n]
|
||||
(renderField f)
|
||||
Nothing
|
||||
@ -388,42 +445,67 @@ hsUnrestricted :: a -> a
|
||||
hsUnrestricted = id
|
||||
#endif
|
||||
|
||||
renderField :: Field -> Located HsType'
|
||||
renderField :: Field -> LHsType GhcPs
|
||||
-- TODO: parenthesizeTypeForApp is an overestimate in the case of
|
||||
-- rendering an infix or record type.
|
||||
renderField f = wrap $ parenthesizeTypeForApp $ builtLoc $ fieldType f
|
||||
renderField f = wrap $ parenthesizeTypeForApp $ mkLocated $ fieldType f
|
||||
where
|
||||
wrap = case strictness f of
|
||||
NoSrcStrict -> id
|
||||
s -> builtLoc . (noExt HsBangTy $ noSourceText HsSrcBang NoSrcUnpack s)
|
||||
s -> mkLocated . (withEpAnnNotUsed HsBangTy $ noSourceText HsSrcBang NoSrcUnpack s)
|
||||
|
||||
renderCon98Decl :: OccNameStr -> HsConDeclDetails' -> ConDecl'
|
||||
renderCon98Decl name details = noExt ConDeclH98 (typeRdrName $ unqual name)
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
(builtLoc False)
|
||||
[]
|
||||
renderCon98Decl name details =
|
||||
conDeclH98 (typeRdrName $ unqual name) False [] Nothing details Nothing
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
conDeclH98 = withEpAnnNotUsed ConDeclH98
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
conDeclH98 n = noExt ConDeclH98 n . builtLoc
|
||||
#else
|
||||
Nothing
|
||||
conDeclH98 n _ _ = ConDeclH98 n Nothing
|
||||
#endif
|
||||
Nothing
|
||||
details
|
||||
Nothing
|
||||
|
||||
deriving' :: [HsType'] -> HsDerivingClause'
|
||||
deriving' = derivingWay Nothing
|
||||
|
||||
derivingWay :: Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
|
||||
derivingWay way ts =
|
||||
noExt HsDerivingClause (fmap builtLoc way) $ builtLoc $ map sigType ts
|
||||
withEpAnnNotUsed HsDerivingClause (fmap builtLoc way) $ mkLocated $ derivClauseTys $ map sigType ts
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
derivClauseTys [x] = noExt DctSingle x
|
||||
derivClauseTys xs = noExt DctMulti xs
|
||||
#else
|
||||
derivClauseTys = id
|
||||
#endif
|
||||
|
||||
derivingStock :: [HsType'] -> HsDerivingClause'
|
||||
derivingStock = derivingWay (Just StockStrategy)
|
||||
derivingStock = derivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed StockStrategy
|
||||
#else
|
||||
strat = StockStrategy
|
||||
#endif
|
||||
|
||||
derivingNewtype :: [HsType'] -> HsDerivingClause'
|
||||
derivingNewtype = derivingWay (Just NewtypeStrategy)
|
||||
derivingNewtype = derivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed NewtypeStrategy
|
||||
#else
|
||||
strat = NewtypeStrategy
|
||||
#endif
|
||||
|
||||
derivingAnyclass :: [HsType'] -> HsDerivingClause'
|
||||
derivingAnyclass = derivingWay (Just AnyclassStrategy)
|
||||
derivingAnyclass = derivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed AnyclassStrategy
|
||||
#else
|
||||
strat = AnyclassStrategy
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
-- | A `DerivingVia` clause.
|
||||
@ -433,27 +515,49 @@ derivingAnyclass = derivingWay (Just AnyclassStrategy)
|
||||
-- > derivingVia (var "T") [var "Eq", var "Show"]
|
||||
-- Available with @ghc>=8.6@.
|
||||
derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'
|
||||
derivingVia t = derivingWay (Just $ ViaStrategy $ sigType t)
|
||||
derivingVia t = derivingWay (Just $ strat $ sigType t)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = ViaStrategy . withEpAnnNotUsed XViaStrategyPs
|
||||
#else
|
||||
strat = ViaStrategy
|
||||
#endif
|
||||
#endif
|
||||
|
||||
standaloneDeriving :: HsType' -> HsDecl'
|
||||
standaloneDeriving = standaloneDerivingWay Nothing
|
||||
|
||||
standaloneDerivingStock :: HsType' -> HsDecl'
|
||||
standaloneDerivingStock = standaloneDerivingWay (Just StockStrategy)
|
||||
standaloneDerivingStock = standaloneDerivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed StockStrategy
|
||||
#else
|
||||
strat = StockStrategy
|
||||
#endif
|
||||
|
||||
standaloneDerivingNewtype :: HsType' -> HsDecl'
|
||||
standaloneDerivingNewtype = standaloneDerivingWay (Just NewtypeStrategy)
|
||||
standaloneDerivingNewtype = standaloneDerivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed NewtypeStrategy
|
||||
#else
|
||||
strat = NewtypeStrategy
|
||||
#endif
|
||||
|
||||
standaloneDerivingAnyclass :: HsType' -> HsDecl'
|
||||
standaloneDerivingAnyclass = standaloneDerivingWay (Just AnyclassStrategy)
|
||||
standaloneDerivingAnyclass = standaloneDerivingWay (Just strat)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
strat = withEpAnnNotUsed AnyclassStrategy
|
||||
#else
|
||||
strat = AnyclassStrategy
|
||||
#endif
|
||||
|
||||
standaloneDerivingWay :: Maybe DerivStrategy' -> HsType' -> HsDecl'
|
||||
standaloneDerivingWay way ty = noExt DerivD derivDecl
|
||||
where derivDecl =
|
||||
noExt DerivDecl (hsWC hsIB) (fmap builtLoc way) Nothing
|
||||
hsIB =
|
||||
withPlaceHolder $ noExtOrPlaceHolder HsIB (builtLoc ty)
|
||||
withEpAnnNotUsed DerivDecl (hsWC $ sigType ty) (fmap builtLoc way) Nothing
|
||||
hsWC =
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
noExt HsWC
|
||||
@ -468,7 +572,7 @@ standaloneDerivingWay way ty = noExt DerivD derivDecl
|
||||
-- > patSynSigs ["F", "G"] $ var "T"
|
||||
patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'
|
||||
patSynSigs names t =
|
||||
sigB $ noExt PatSynSig (map (typeRdrName . unqual) names)
|
||||
sigB $ withEpAnnNotUsed PatSynSig (map (typeRdrName . unqual) names)
|
||||
$ sigType t
|
||||
|
||||
-- | Declares a pattern signature and its type.
|
||||
@ -488,8 +592,14 @@ patSynSig n = patSynSigs [n]
|
||||
-- > patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"]
|
||||
patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'
|
||||
patSynBind n ns p = bindB $ noExt PatSynBind
|
||||
$ withPlaceHolder (noExt PSB (valueRdrName $ unqual n))
|
||||
(PrefixCon (map (valueRdrName . unqual) ns))
|
||||
$ withPlaceHolder (withEpAnnNotUsed PSB (valueRdrName $ unqual n))
|
||||
(prefixCon' (map (valueRdrName . unqual) ns))
|
||||
(builtPat p)
|
||||
ImplicitBidirectional
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
prefixCon' = PrefixCon []
|
||||
#else
|
||||
prefixCon' = PrefixCon
|
||||
#endif
|
||||
|
||||
|
@ -35,9 +35,13 @@ import GHC.Hs.Type (FieldOcc(..), AmbiguousFieldOcc(..))
|
||||
import GHC.Hs.Utils (mkHsIf)
|
||||
import Data.String (fromString)
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.SrcLoc (unLoc, GenLocated(..), Located)
|
||||
import GHC.Types.SrcLoc (unLoc, GenLocated(..))
|
||||
#else
|
||||
import SrcLoc (unLoc, GenLocated(..), Located)
|
||||
import SrcLoc (unLoc, GenLocated(..))
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Parser.Annotation (EpAnn(..))
|
||||
#endif
|
||||
|
||||
import GHC.SourceGen.Binds.Internal
|
||||
@ -57,23 +61,41 @@ import GHC.SourceGen.Type.Internal
|
||||
-- > =====
|
||||
-- > overLabel "foo"
|
||||
overLabel :: String -> HsExpr'
|
||||
overLabel = noExt HsOverLabel Nothing . fromString
|
||||
overLabel = hsOverLabel . fromString
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
hsOverLabel = withEpAnnNotUsed HsOverLabel
|
||||
#else
|
||||
hsOverLabel = noExt HsOverLabel Nothing
|
||||
#endif
|
||||
|
||||
let' :: [RawValBind] -> HsExpr' -> HsExpr'
|
||||
let' binds e = noExt HsLet (builtLoc $ valBinds binds) $ builtLoc e
|
||||
let' binds e = withEpAnnNotUsed HsLet (toHsLocalBinds $ valBinds binds) $ mkLocated e
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
toHsLocalBinds = id
|
||||
#else
|
||||
toHsLocalBinds = builtLoc
|
||||
#endif
|
||||
|
||||
case' :: HsExpr' -> [RawMatch] -> HsExpr'
|
||||
case' e matches = noExt HsCase (builtLoc e)
|
||||
case' e matches = withEpAnnNotUsed HsCase (mkLocated e)
|
||||
$ matchGroup CaseAlt matches
|
||||
|
||||
lambda :: [Pat'] -> HsExpr' -> HsExpr'
|
||||
lambda ps e = noExt HsLam $ matchGroup LambdaExpr [match ps e]
|
||||
|
||||
lambdaCase :: [RawMatch] -> HsExpr'
|
||||
lambdaCase = noExt HsLamCase . matchGroup CaseAlt
|
||||
lambdaCase = withEpAnnNotUsed HsLamCase . matchGroup CaseAlt
|
||||
|
||||
if' :: HsExpr' -> HsExpr' -> HsExpr' -> HsExpr'
|
||||
if' x y z = mkHsIf (builtLoc x) (builtLoc y) (builtLoc z)
|
||||
if' x y z = mkHsIf
|
||||
(mkLocated x)
|
||||
(mkLocated y)
|
||||
(mkLocated z)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
EpAnnNotUsed
|
||||
#endif
|
||||
|
||||
-- | A MultiWayIf expression.
|
||||
--
|
||||
@ -87,7 +109,7 @@ if' x y z = mkHsIf (builtLoc x) (builtLoc y) (builtLoc z)
|
||||
-- > , guardedStmt (var "otherwise") $ rhs (string "h")
|
||||
-- > ]
|
||||
multiIf :: [GuardedExpr] -> HsExpr'
|
||||
multiIf = noExtOrPlaceHolder HsMultiIf . map builtLoc
|
||||
multiIf = withPlaceHolder (withEpAnnNotUsed HsMultiIf) . map builtLoc
|
||||
|
||||
-- | A do-expression.
|
||||
--
|
||||
@ -101,11 +123,11 @@ multiIf = noExtOrPlaceHolder HsMultiIf . map builtLoc
|
||||
do' :: [Stmt'] -> HsExpr'
|
||||
do' = withPlaceHolder
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
. noExt HsDo (DoExpr Nothing)
|
||||
. withEpAnnNotUsed HsDo (DoExpr Nothing)
|
||||
#else
|
||||
. noExt HsDo DoExpr
|
||||
#endif
|
||||
. builtLoc . map (builtLoc . parenthesizeIfLet)
|
||||
. mkLocated . map (mkLocated . parenthesizeIfLet)
|
||||
where
|
||||
-- Put parentheses around a "let" in a do-binding, to avoid:
|
||||
-- do let x = ...
|
||||
@ -130,13 +152,13 @@ do' = withPlaceHolder
|
||||
-- > ]
|
||||
listComp :: HsExpr' -> [Stmt'] -> HsExpr'
|
||||
listComp lastExpr stmts =
|
||||
let lastStmt = noExt LastStmt (builtLoc lastExpr) ret noSyntaxExpr
|
||||
let lastStmt = noExt LastStmt (mkLocated lastExpr) ret noSyntaxExpr
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
ret = Nothing
|
||||
#else
|
||||
ret = False
|
||||
#endif
|
||||
in withPlaceHolder . noExt HsDo ListComp . builtLoc . map builtLoc $
|
||||
in withPlaceHolder . withEpAnnNotUsed HsDo ListComp . mkLocated . map mkLocated $
|
||||
stmts ++ [lastStmt]
|
||||
|
||||
-- | A type constraint on an expression.
|
||||
@ -146,7 +168,7 @@ listComp lastExpr stmts =
|
||||
-- > var "e" @::@ var "t"
|
||||
(@::@) :: HsExpr' -> HsType' -> HsExpr'
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
e @::@ t = noExt ExprWithTySig (builtLoc e) (sigWcType t)
|
||||
e @::@ t = withEpAnnNotUsed ExprWithTySig (mkLocated e) (sigWcType t)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
e @::@ t = ExprWithTySig (sigWcType t) (builtLoc e)
|
||||
#else
|
||||
@ -160,7 +182,9 @@ e @::@ t = ExprWithTySig (builtLoc e) (sigWcType t)
|
||||
-- > =====
|
||||
-- > var "f" @@ var "Int"
|
||||
tyApp :: HsExpr' -> HsType' -> HsExpr'
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
tyApp e t = HsAppType builtSpan e' t'
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
tyApp e t = noExt HsAppType e' t'
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
tyApp e t = HsAppType t' e'
|
||||
@ -168,8 +192,8 @@ tyApp e t = HsAppType t' e'
|
||||
tyApp e t = HsAppType e' t'
|
||||
#endif
|
||||
where
|
||||
t' = wcType $ unLoc $ parenthesizeTypeForApp $ builtLoc t
|
||||
e' = builtLoc e
|
||||
t' = wcType $ unLoc $ parenthesizeTypeForApp $ mkLocated t
|
||||
e' = mkLocated e
|
||||
|
||||
-- | Constructs a record with explicit field names.
|
||||
--
|
||||
@ -177,20 +201,23 @@ tyApp e t = HsAppType e' t'
|
||||
-- > =====
|
||||
-- > recordConE "A" [("x", var "y")]
|
||||
recordConE :: RdrNameStr -> [(RdrNameStr, HsExpr')] -> HsExpr'
|
||||
recordConE c fs = (withPlaceHolder $ noExt RecordCon (valueRdrName c))
|
||||
recordConE c fs = (withPlaceHolder $ withEpAnnNotUsed RecordCon (valueRdrName c))
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
noPostTcExpr
|
||||
#endif
|
||||
$ HsRecFields (map recField fs)
|
||||
Nothing -- No ".."
|
||||
where
|
||||
recField :: (RdrNameStr, HsExpr') -> LHsRecField' (Located HsExpr')
|
||||
recField :: (RdrNameStr, HsExpr') -> LHsRecField' LHsExpr'
|
||||
recField (f, e) =
|
||||
builtLoc HsRecField
|
||||
mkLocated HsRecField
|
||||
{ hsRecFieldLbl =
|
||||
builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f
|
||||
, hsRecFieldArg = builtLoc e
|
||||
, hsRecFieldArg = mkLocated e
|
||||
, hsRecPun = False
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, hsRecFieldAnn = EpAnnNotUsed
|
||||
#endif
|
||||
}
|
||||
|
||||
-- | Updates a record expression with explicit field names.
|
||||
@ -209,26 +236,34 @@ recordConE c fs = (withPlaceHolder $ noExt RecordCon (valueRdrName c))
|
||||
recordUpd :: HsExpr' -> [(RdrNameStr, HsExpr')] -> HsExpr'
|
||||
recordUpd e fs =
|
||||
withPlaceHolder4
|
||||
$ noExt RecordUpd (parenthesizeExprForApp $ builtLoc e)
|
||||
$ map mkField fs
|
||||
$ withEpAnnNotUsed RecordUpd (parenthesizeExprForApp $ mkLocated e)
|
||||
$ toRecordUpdFields $ map mkField fs
|
||||
where
|
||||
mkField :: (RdrNameStr, HsExpr') -> LHsRecUpdField'
|
||||
mkField (f, e') =
|
||||
builtLoc HsRecField
|
||||
mkLocated HsRecField
|
||||
{ hsRecFieldLbl =
|
||||
builtLoc $ withPlaceHolder $ noExt Ambiguous $ valueRdrName f
|
||||
, hsRecFieldArg = builtLoc e'
|
||||
, hsRecFieldArg = mkLocated e'
|
||||
, hsRecPun = False
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, hsRecFieldAnn = EpAnnNotUsed
|
||||
#endif
|
||||
}
|
||||
withPlaceHolder4 = withPlaceHolder . withPlaceHolder . withPlaceHolder
|
||||
. withPlaceHolder
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
toRecordUpdFields = Left
|
||||
#else
|
||||
toRecordUpdFields = id
|
||||
#endif
|
||||
|
||||
arithSeq :: ArithSeqInfo GhcPs -> HsExpr'
|
||||
arithSeq =
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
ArithSeq noPostTcExpr Nothing
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
withEpAnnNotUsed ArithSeq Nothing
|
||||
#else
|
||||
noExt ArithSeq Nothing
|
||||
ArithSeq noPostTcExpr Nothing
|
||||
#endif
|
||||
|
||||
-- | An arithmetic sequence expression with a start value.
|
||||
@ -237,7 +272,7 @@ arithSeq =
|
||||
-- > =====
|
||||
-- > from (var "a")
|
||||
from :: HsExpr' -> HsExpr'
|
||||
from from' = arithSeq $ From (builtLoc from')
|
||||
from from' = arithSeq $ From (mkLocated from')
|
||||
|
||||
-- | An arithmetic sequence expression with a start and a step values.
|
||||
--
|
||||
@ -245,7 +280,7 @@ from from' = arithSeq $ From (builtLoc from')
|
||||
-- > =====
|
||||
-- > fromThen (var "a") (var "b")
|
||||
fromThen :: HsExpr' -> HsExpr' -> HsExpr'
|
||||
fromThen from' then' = arithSeq $ FromThen (builtLoc from') (builtLoc then')
|
||||
fromThen from' then' = arithSeq $ FromThen (mkLocated from') (mkLocated then')
|
||||
|
||||
-- | An arithmetic sequence expression with a start and an end values.
|
||||
--
|
||||
@ -253,7 +288,7 @@ fromThen from' then' = arithSeq $ FromThen (builtLoc from') (builtLoc then')
|
||||
-- > =====
|
||||
-- > fromTo (var "a") (var "b")
|
||||
fromTo :: HsExpr' -> HsExpr' -> HsExpr'
|
||||
fromTo from' to = arithSeq $ FromTo (builtLoc from') (builtLoc to)
|
||||
fromTo from' to = arithSeq $ FromTo (mkLocated from') (mkLocated to)
|
||||
|
||||
-- | An arithmetic sequence expression with a start, a step, and an end values.
|
||||
--
|
||||
@ -262,4 +297,4 @@ fromTo from' to = arithSeq $ FromTo (builtLoc from') (builtLoc to)
|
||||
-- > fromThenTo (var "a") (var "b") (var "c")
|
||||
fromThenTo :: HsExpr' -> HsExpr' -> HsExpr' -> HsExpr'
|
||||
fromThenTo from' then' to =
|
||||
arithSeq $ FromThenTo (builtLoc from') (builtLoc then') (builtLoc to)
|
||||
arithSeq $ FromThenTo (mkLocated from') (mkLocated then') (mkLocated to)
|
||||
|
@ -9,16 +9,16 @@ module GHC.SourceGen.Expr.Internal where
|
||||
|
||||
import GHC.Hs.Expr
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.SrcLoc (Located, unLoc)
|
||||
import GHC.Types.SrcLoc (unLoc)
|
||||
#else
|
||||
import SrcLoc (Located, unLoc)
|
||||
import SrcLoc (unLoc)
|
||||
#endif
|
||||
|
||||
import GHC.SourceGen.Lit.Internal
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
|
||||
parenthesizeExprForApp, parenthesizeExprForOp
|
||||
:: Located HsExpr' -> Located HsExpr'
|
||||
:: LHsExpr' -> LHsExpr'
|
||||
parenthesizeExprForApp e
|
||||
| needsExprForApp (unLoc e) = parExpr e
|
||||
| otherwise = e
|
||||
@ -26,8 +26,8 @@ parenthesizeExprForOp e
|
||||
| needsExprForOp (unLoc e) = parExpr e
|
||||
| otherwise = e
|
||||
|
||||
parExpr :: Located HsExpr' -> Located HsExpr'
|
||||
parExpr = builtLoc . noExt HsPar
|
||||
parExpr :: LHsExpr' -> LHsExpr'
|
||||
parExpr = mkLocated . withEpAnnNotUsed HsPar
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
#define WILD_EXT _
|
||||
|
@ -17,11 +17,14 @@ module GHC.SourceGen.Lit
|
||||
, frac
|
||||
) where
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (FractionalLit(..), IntegralLit(..), SourceText(..))
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Types.SourceText (mkTHFractionalLit, mkIntegralLit)
|
||||
import GHC.Data.FastString (fsLit)
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (mkFractionalLit, mkIntegralLit)
|
||||
import GHC.Data.FastString (fsLit)
|
||||
#else
|
||||
import BasicTypes (FractionalLit(..), IntegralLit(..), SourceText(..))
|
||||
import BasicTypes (mkFractionalLit, mkIntegralLit)
|
||||
import FastString (fsLit)
|
||||
#endif
|
||||
import GHC.Hs.Lit
|
||||
@ -36,13 +39,13 @@ class HasLit e where
|
||||
overLit :: HsOverLit' -> e
|
||||
|
||||
instance HasLit HsExpr' where
|
||||
lit = noExt HsLit
|
||||
overLit = noExt HsOverLit
|
||||
lit = withEpAnnNotUsed HsLit
|
||||
overLit = withEpAnnNotUsed HsOverLit
|
||||
|
||||
instance HasLit Pat' where
|
||||
lit = noExt LitPat
|
||||
overLit l = withPlaceHolder
|
||||
$ noExt NPat (builtLoc l) Nothing noSyntaxExpr
|
||||
$ withEpAnnNotUsed NPat (builtLoc l) Nothing noSyntaxExpr
|
||||
|
||||
char :: HasLit e => Char -> e
|
||||
char = lit . noSourceText HsChar
|
||||
@ -52,13 +55,16 @@ string = lit . noSourceText HsString . fsLit
|
||||
|
||||
-- | Note: this is an *overloaded* integer.
|
||||
int :: HasLit e => Integer -> e
|
||||
int n = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit il) noExpr
|
||||
int n = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit n') noExpr
|
||||
where
|
||||
il = HsIntegral $ noSourceText IL (n < 0) n
|
||||
n' = HsIntegral $ mkIntegralLit n
|
||||
|
||||
-- | Note: this is an *overloaded* rational, e.g., a decimal number.
|
||||
frac :: HasLit e => Rational -> e
|
||||
frac x = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit $ HsFractional il) noExpr
|
||||
frac x = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit $ HsFractional x') noExpr
|
||||
where
|
||||
il = FL (SourceText s) (x < 0) x
|
||||
s = show (fromRational x :: Double)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
x' = mkTHFractionalLit x
|
||||
#else
|
||||
x' = mkFractionalLit x
|
||||
#endif
|
||||
|
@ -7,7 +7,9 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GHC.SourceGen.Lit.Internal where
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Types.SourceText (SourceText(NoSourceText), FractionalLit(..), IntegralLit(..))
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (SourceText(NoSourceText), FractionalLit(..), IntegralLit(..))
|
||||
#else
|
||||
import BasicTypes (SourceText(NoSourceText), FractionalLit(..), IntegralLit(..))
|
||||
|
@ -32,6 +32,9 @@ import GHC.Hs
|
||||
, ImportDecl(..)
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
, ImportDeclQualifiedStyle(..)
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, EpAnn(..)
|
||||
#endif
|
||||
)
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
@ -54,14 +57,17 @@ module'
|
||||
-> [HsDecl']
|
||||
-> HsModule'
|
||||
module' name exports imports decls = HsModule
|
||||
{ hsmodName = fmap (builtLoc . unModuleNameStr) name
|
||||
, hsmodExports = fmap (builtLoc . map builtLoc) exports
|
||||
, hsmodImports = map builtLoc imports
|
||||
, hsmodDecls = fmap builtLoc decls
|
||||
{ hsmodName = fmap (mkLocated . unModuleNameStr) name
|
||||
, hsmodExports = fmap (mkLocated . map mkLocated) exports
|
||||
, hsmodImports = map mkLocated imports
|
||||
, hsmodDecls = fmap mkLocated decls
|
||||
, hsmodDeprecMessage = Nothing
|
||||
, hsmodHaddockModHeader = Nothing
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
, hsmodLayout = NoLayoutInfo
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, hsmodAnn = EpAnnNotUsed
|
||||
#endif
|
||||
}
|
||||
|
||||
@ -75,11 +81,11 @@ qualified' d = d { ideclQualified =
|
||||
}
|
||||
|
||||
as' :: ImportDecl' -> ModuleNameStr -> ImportDecl'
|
||||
as' d m = d { ideclAs = Just (builtLoc $ unModuleNameStr m) }
|
||||
as' d m = d { ideclAs = Just (mkLocated $ unModuleNameStr m) }
|
||||
|
||||
import' :: ModuleNameStr -> ImportDecl'
|
||||
import' m = noSourceText (noExt ImportDecl)
|
||||
(builtLoc $ unModuleNameStr m)
|
||||
import' m = noSourceText (withEpAnnNotUsed ImportDecl)
|
||||
(mkLocated $ unModuleNameStr m)
|
||||
Nothing
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
NotBoot
|
||||
@ -96,11 +102,11 @@ import' m = noSourceText (noExt ImportDecl)
|
||||
|
||||
exposing :: ImportDecl' -> [IE'] -> ImportDecl'
|
||||
exposing d ies = d
|
||||
{ ideclHiding = Just (False, builtLoc $ map builtLoc ies) }
|
||||
{ ideclHiding = Just (False, mkLocated $ map mkLocated ies) }
|
||||
|
||||
hiding :: ImportDecl' -> [IE'] -> ImportDecl'
|
||||
hiding d ies = d
|
||||
{ ideclHiding = Just (True, builtLoc $ map builtLoc ies) }
|
||||
{ ideclHiding = Just (True, mkLocated $ map mkLocated ies) }
|
||||
|
||||
-- | Adds the @{-# SOURCE #-}@ pragma to an import.
|
||||
source :: ImportDecl' -> ImportDecl'
|
||||
@ -118,7 +124,7 @@ source d = d { ideclSource =
|
||||
-- > =====
|
||||
-- > thingAll "A"
|
||||
thingAll :: RdrNameStr -> IE'
|
||||
thingAll = noExt IEThingAll . wrappedName
|
||||
thingAll = withEpAnnNotUsed IEThingAll . wrappedName
|
||||
|
||||
-- | Exports specific methods and/or constructors.
|
||||
--
|
||||
@ -126,17 +132,19 @@ thingAll = noExt IEThingAll . wrappedName
|
||||
-- > =====
|
||||
-- > thingWith "A" ["b", "C"]
|
||||
thingWith :: RdrNameStr -> [OccNameStr] -> IE'
|
||||
thingWith n cs = noExt IEThingWith (wrappedName n) NoIEWildcard
|
||||
thingWith n cs = withEpAnnNotUsed IEThingWith (wrappedName n) NoIEWildcard
|
||||
(map (wrappedName . unqual) cs)
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
-- The parsing step leaves the list of fields empty
|
||||
-- and lumps them all together with the above list of
|
||||
-- constructors.
|
||||
[]
|
||||
#endif
|
||||
|
||||
-- TODO: support "mixed" syntax with both ".." and explicit names.
|
||||
|
||||
wrappedName :: RdrNameStr -> LIEWrappedName RdrName
|
||||
wrappedName = builtLoc . IEName . exportRdrName
|
||||
wrappedName = mkLocated . IEName . exportRdrName
|
||||
|
||||
-- | Exports an entire module.
|
||||
--
|
||||
@ -146,4 +154,4 @@ wrappedName = builtLoc . IEName . exportRdrName
|
||||
-- > =====
|
||||
-- > moduleContents "M"
|
||||
moduleContents :: ModuleNameStr -> IE'
|
||||
moduleContents = noExt IEModuleContents . builtLoc . unModuleNameStr
|
||||
moduleContents = withEpAnnNotUsed IEModuleContents . mkLocated . unModuleNameStr
|
||||
|
@ -8,6 +8,7 @@
|
||||
module GHC.SourceGen.Name.Internal where
|
||||
|
||||
import Data.Char (isAlphaNum, isUpper)
|
||||
import Data.Function (on)
|
||||
import Data.List (intercalate)
|
||||
import Data.String (IsString(..))
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
@ -15,16 +16,26 @@ import GHC.Data.FastString (FastString, fsLit)
|
||||
import GHC.Unit.Module (mkModuleNameFS, ModuleName, moduleNameString)
|
||||
import GHC.Types.Name.Occurrence
|
||||
import GHC.Types.Name.Reader
|
||||
import GHC.Types.SrcLoc (Located)
|
||||
#else
|
||||
import FastString (FastString, fsLit)
|
||||
import Module (mkModuleNameFS, ModuleName, moduleNameString)
|
||||
import OccName
|
||||
import RdrName
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Data.FastString (LexicalFastString(..))
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Parser.Annotation (LocatedN)
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.SrcLoc (Located)
|
||||
#else
|
||||
import SrcLoc (Located)
|
||||
#endif
|
||||
|
||||
import GHC.SourceGen.Syntax.Internal (builtLoc)
|
||||
import GHC.SourceGen.Syntax.Internal (mkLocated)
|
||||
|
||||
-- | A string identifier referring to a name.
|
||||
--
|
||||
@ -39,7 +50,16 @@ import GHC.SourceGen.Syntax.Internal (builtLoc)
|
||||
-- makes it easier to implement an 'IsString' instance without the context
|
||||
-- where a name would be used.)
|
||||
data OccNameStr = OccNameStr !RawNameSpace !FastString
|
||||
deriving (Show, Eq, Ord)
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Ord OccNameStr where
|
||||
compare = compare `on` (\(OccNameStr n s) -> (n, fromFastString s))
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
fromFastString = LexicalFastString
|
||||
#else
|
||||
fromFastString = id
|
||||
#endif
|
||||
|
||||
data RawNameSpace = Constructor | Value
|
||||
deriving (Show, Eq, Ord)
|
||||
@ -90,13 +110,17 @@ instance IsString ModuleNameStr where
|
||||
data RdrNameStr = UnqualStr OccNameStr | QualStr ModuleNameStr OccNameStr
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
#if !MIN_VERSION_ghc(9,2,0)
|
||||
type LocatedN e = Located e
|
||||
#endif
|
||||
|
||||
-- GHC always wraps RdrName in a Located. (Usually: 'Located (IdP pass)')
|
||||
-- So for convenience, these functions return a Located-wrapped value.
|
||||
valueRdrName, typeRdrName :: RdrNameStr -> Located RdrName
|
||||
valueRdrName (UnqualStr r) = builtLoc $ Unqual $ valueOccName r
|
||||
valueRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ valueOccName r
|
||||
typeRdrName (UnqualStr r) = builtLoc $ Unqual $ typeOccName r
|
||||
typeRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ typeOccName r
|
||||
valueRdrName, typeRdrName :: RdrNameStr -> LocatedN RdrName
|
||||
valueRdrName (UnqualStr r) = mkLocated $ Unqual $ valueOccName r
|
||||
valueRdrName (QualStr (ModuleNameStr m) r) = mkLocated $ Qual m $ valueOccName r
|
||||
typeRdrName (UnqualStr r) = mkLocated $ Unqual $ typeOccName r
|
||||
typeRdrName (QualStr (ModuleNameStr m) r) = mkLocated $ Qual m $ typeOccName r
|
||||
|
||||
-- TODO: operators
|
||||
instance IsString RdrNameStr where
|
||||
@ -122,9 +146,9 @@ collectModuleName s = case span isVarChar s of
|
||||
-- E.g.: `import F(a, B)`
|
||||
-- The 'a' should be a value, but the 'B' should be a type/class.
|
||||
-- (Currently, GHC doesn't distinguish the class and type namespaces.)
|
||||
exportRdrName :: RdrNameStr -> Located RdrName
|
||||
exportRdrName (UnqualStr r) = builtLoc $ Unqual $ exportOccName r
|
||||
exportRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ exportOccName r
|
||||
exportRdrName :: RdrNameStr -> LocatedN RdrName
|
||||
exportRdrName (UnqualStr r) = mkLocated $ Unqual $ exportOccName r
|
||||
exportRdrName (QualStr (ModuleNameStr m) r) = mkLocated $ Qual m $ exportOccName r
|
||||
|
||||
exportOccName :: OccNameStr -> OccName
|
||||
exportOccName (OccNameStr Value s) = mkVarOccFS s
|
||||
|
@ -36,15 +36,13 @@ import GHC.Hs
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (Boxity(..))
|
||||
import GHC.Core.DataCon (dataConName)
|
||||
import GHC.Types.Name.Reader (RdrName(..), nameRdrName)
|
||||
import GHC.Types.SrcLoc (Located)
|
||||
import GHC.Types.Name.Reader (nameRdrName)
|
||||
import GHC.Builtin.Types (consDataCon_RDR, nilDataCon, unitDataCon)
|
||||
import GHC.Types.Var (Specificity(..))
|
||||
#else
|
||||
import BasicTypes (Boxity(..))
|
||||
import DataCon (dataConName)
|
||||
import RdrName (RdrName(..), nameRdrName)
|
||||
import SrcLoc (Located)
|
||||
import RdrName (nameRdrName)
|
||||
import TysWiredIn (consDataCon_RDR, nilDataCon, unitDataCon)
|
||||
#endif
|
||||
|
||||
@ -58,13 +56,13 @@ class Par e where
|
||||
par :: e -> e
|
||||
|
||||
instance Par HsExpr' where
|
||||
par = noExt HsPar . builtLoc
|
||||
par = withEpAnnNotUsed HsPar . mkLocated
|
||||
|
||||
instance Par Pat' where
|
||||
par = noExt ParPat . builtPat
|
||||
par = withEpAnnNotUsed ParPat . builtPat
|
||||
|
||||
instance Par HsType' where
|
||||
par = noExt HsParTy . builtLoc
|
||||
par = withEpAnnNotUsed HsParTy . mkLocated
|
||||
|
||||
-- | A class for term application.
|
||||
--
|
||||
@ -129,24 +127,24 @@ infixl 2 @@
|
||||
|
||||
instance App HsExpr' where
|
||||
op x o y
|
||||
= noExt OpApp
|
||||
(parenthesizeExprForOp $ builtLoc x)
|
||||
(builtLoc $ var o)
|
||||
= withEpAnnNotUsed OpApp
|
||||
(parenthesizeExprForOp $ mkLocated x)
|
||||
(mkLocated $ var o)
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
PlaceHolder
|
||||
#endif
|
||||
(parenthesizeExprForOp $ builtLoc y)
|
||||
x @@ y = noExt HsApp (parenthesizeExprForOp $ builtLoc x)
|
||||
(parenthesizeExprForApp $ builtLoc y)
|
||||
(parenthesizeExprForOp $ mkLocated y)
|
||||
x @@ y = withEpAnnNotUsed HsApp (parenthesizeExprForOp $ mkLocated x)
|
||||
(parenthesizeExprForApp $ mkLocated y)
|
||||
|
||||
instance App HsType' where
|
||||
op x o y
|
||||
= noExt HsOpTy (parenthesizeTypeForOp $ builtLoc x)
|
||||
= noExt HsOpTy (parenthesizeTypeForOp $ mkLocated x)
|
||||
(typeRdrName o)
|
||||
(parenthesizeTypeForOp $ builtLoc y)
|
||||
(parenthesizeTypeForOp $ mkLocated y)
|
||||
x @@ y = noExt HsAppTy
|
||||
(parenthesizeTypeForOp $ builtLoc x)
|
||||
(parenthesizeTypeForApp $ builtLoc y)
|
||||
(parenthesizeTypeForOp $ mkLocated x)
|
||||
(parenthesizeTypeForApp $ mkLocated y)
|
||||
|
||||
class HasTuple e where
|
||||
unit :: e
|
||||
@ -158,16 +156,22 @@ unboxedTuple = tupleOf Unboxed
|
||||
|
||||
instance HasTuple HsExpr' where
|
||||
tupleOf b ts =
|
||||
noExt ExplicitTuple
|
||||
(map (builtLoc . noExt Present . builtLoc) ts)
|
||||
explicitTuple
|
||||
(map (withEpAnnNotUsed Present . mkLocated) ts)
|
||||
b
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
explicitTuple = withEpAnnNotUsed ExplicitTuple
|
||||
#else
|
||||
explicitTuple = noExt ExplicitTuple . map builtLoc
|
||||
#endif
|
||||
unit = noExt HsVar unitDataConName
|
||||
|
||||
unitDataConName :: Located RdrName
|
||||
unitDataConName = builtLoc $ nameRdrName $ dataConName $ unitDataCon
|
||||
unitDataConName :: LIdP
|
||||
unitDataConName = mkLocated $ nameRdrName $ dataConName $ unitDataCon
|
||||
|
||||
instance HasTuple HsType' where
|
||||
tupleOf b = noExt HsTupleTy b' . map builtLoc
|
||||
tupleOf b = withEpAnnNotUsed HsTupleTy b' . map mkLocated
|
||||
where
|
||||
b' = case b of
|
||||
Unboxed -> HsUnboxedTuple
|
||||
@ -178,7 +182,7 @@ instance HasTuple HsType' where
|
||||
|
||||
instance HasTuple Pat' where
|
||||
tupleOf b ps =
|
||||
noExt TuplePat (map builtPat ps) b
|
||||
withEpAnnNotUsed TuplePat (map builtPat ps) b
|
||||
#if !MIN_VERSION_ghc(8,6,0)
|
||||
[]
|
||||
#endif
|
||||
@ -202,22 +206,28 @@ class HasList e where
|
||||
-- TODO: allow something like "consOp" which applies (:) as an operator, but using
|
||||
-- the built-in RdrName.
|
||||
|
||||
nilDataConName :: Located RdrName
|
||||
nilDataConName = builtLoc $ nameRdrName $ dataConName $ nilDataCon
|
||||
nilDataConName :: LIdP
|
||||
nilDataConName = mkLocated $ nameRdrName $ dataConName $ nilDataCon
|
||||
|
||||
instance HasList HsExpr' where
|
||||
list = withPlaceHolder (noExt ExplicitList) Nothing . map builtLoc
|
||||
list = withPlaceHolder (withEpAnnNotUsed explicitList) . map mkLocated
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
explicitList = ExplicitList
|
||||
#else
|
||||
explicitList x = ExplicitList x Nothing
|
||||
#endif
|
||||
nil = noExt HsVar nilDataConName
|
||||
cons = noExt HsVar $ builtLoc consDataCon_RDR
|
||||
cons = noExt HsVar $ mkLocated consDataCon_RDR
|
||||
|
||||
instance HasList Pat' where
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
list = noExt ListPat . map builtPat
|
||||
list = withEpAnnNotUsed ListPat . map builtPat
|
||||
#else
|
||||
list ps = ListPat (map builtPat ps) PlaceHolder Nothing
|
||||
#endif
|
||||
nil = noExt VarPat nilDataConName
|
||||
cons = noExt VarPat $ builtLoc $ consDataCon_RDR
|
||||
cons = noExt VarPat $ mkLocated $ consDataCon_RDR
|
||||
|
||||
-- | Terms that can contain references to locally-bound variables.
|
||||
--
|
||||
@ -245,24 +255,24 @@ instance BVar HsExpr' where
|
||||
bvar = var . UnqualStr
|
||||
|
||||
instance Var HsType' where
|
||||
var = noExt HsTyVar notPromoted . typeRdrName
|
||||
var = withEpAnnNotUsed HsTyVar notPromoted . typeRdrName
|
||||
|
||||
instance BVar HsType' where
|
||||
bvar = var . UnqualStr
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
instance BVar HsTyVarBndr' where
|
||||
bvar = noExt UserTyVar () . typeRdrName . UnqualStr
|
||||
bvar = withEpAnnNotUsed UserTyVar () . typeRdrName . UnqualStr
|
||||
|
||||
instance BVar HsTyVarBndrS' where
|
||||
bvar = noExt UserTyVar SpecifiedSpec . typeRdrName . UnqualStr
|
||||
bvar = withEpAnnNotUsed UserTyVar SpecifiedSpec . typeRdrName . UnqualStr
|
||||
#else
|
||||
instance BVar HsTyVarBndr' where
|
||||
bvar = noExt UserTyVar . typeRdrName . UnqualStr
|
||||
bvar = withEpAnnNotUsed UserTyVar . typeRdrName . UnqualStr
|
||||
#endif
|
||||
|
||||
instance Var IE' where
|
||||
var n = noExt IEVar $ builtLoc $ IEName $ exportRdrName n
|
||||
var n = noExt IEVar $ mkLocated $ IEName $ exportRdrName n
|
||||
|
||||
instance BVar IE' where
|
||||
bvar = var . UnqualStr
|
||||
|
@ -26,6 +26,10 @@ import GHC.SourceGen.Pat.Internal
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
import GHC.SourceGen.Type.Internal (patSigType)
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Parser.Annotation (EpAnn(..))
|
||||
#endif
|
||||
|
||||
-- | A wild pattern (@_@).
|
||||
wildP :: Pat'
|
||||
wildP = noExtOrPlaceHolder WildPat
|
||||
@ -36,7 +40,7 @@ wildP = noExtOrPlaceHolder WildPat
|
||||
-- > =====
|
||||
-- > asP "a" (var "B")
|
||||
asP :: RdrNameStr -> Pat' -> Pat'
|
||||
v `asP` p = noExt AsPat (valueRdrName v) $ builtPat $ parenthesize p
|
||||
v `asP` p = withEpAnnNotUsed AsPat (valueRdrName v) $ builtPat $ parenthesize p
|
||||
|
||||
-- | A pattern constructor.
|
||||
--
|
||||
@ -44,14 +48,18 @@ v `asP` p = noExt AsPat (valueRdrName v) $ builtPat $ parenthesize p
|
||||
-- > =====
|
||||
-- > conP "A" [bvar "b", bvar "c"]
|
||||
conP :: RdrNameStr -> [Pat'] -> Pat'
|
||||
conP c xs =
|
||||
conP c = conPat (valueRdrName c) . prefixCon . map (builtPat . parenthesize)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
noExt ConPat
|
||||
conPat = withEpAnnNotUsed ConPat
|
||||
#else
|
||||
ConPatIn
|
||||
conPat = ConPatIn
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
prefixCon = PrefixCon []
|
||||
#else
|
||||
prefixCon = PrefixCon
|
||||
#endif
|
||||
(valueRdrName c) $ PrefixCon
|
||||
$ map (builtPat . parenthesize) xs
|
||||
|
||||
-- | A pattern constructor with no arguments.
|
||||
--
|
||||
@ -64,7 +72,7 @@ conP_ c = conP c []
|
||||
recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'
|
||||
recordConP c fs =
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
noExt ConPat
|
||||
withEpAnnNotUsed ConPat
|
||||
#else
|
||||
ConPatIn
|
||||
#endif
|
||||
@ -73,11 +81,14 @@ recordConP c fs =
|
||||
where
|
||||
mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
|
||||
mkRecField (f, p) =
|
||||
builtLoc $ HsRecField
|
||||
mkLocated $ HsRecField
|
||||
{ hsRecFieldLbl =
|
||||
builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f
|
||||
, hsRecFieldArg = builtPat p
|
||||
, hsRecPun = False
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, hsRecFieldAnn = EpAnnNotUsed
|
||||
#endif
|
||||
}
|
||||
|
||||
-- | A bang-pattern.
|
||||
@ -86,7 +97,7 @@ recordConP c fs =
|
||||
-- > =====
|
||||
-- > strictP (bvar x)
|
||||
strictP :: Pat' -> Pat'
|
||||
strictP = noExt BangPat . builtPat . parenthesize
|
||||
strictP = withEpAnnNotUsed BangPat . builtPat . parenthesize
|
||||
|
||||
-- | A lazy pattern match.
|
||||
--
|
||||
@ -94,7 +105,7 @@ strictP = noExt BangPat . builtPat . parenthesize
|
||||
-- > =====
|
||||
-- > lazyP (conP "A" [bvar x])
|
||||
lazyP :: Pat' -> Pat'
|
||||
lazyP = noExt LazyPat . builtPat . parenthesize
|
||||
lazyP = withEpAnnNotUsed LazyPat . builtPat . parenthesize
|
||||
|
||||
-- | A pattern type signature
|
||||
--
|
||||
@ -103,7 +114,7 @@ lazyP = noExt LazyPat . builtPat . parenthesize
|
||||
-- > sigPat (bvar "x") (var "y")
|
||||
sigP :: Pat' -> HsType' -> Pat'
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
sigP p t = noExt SigPat (builtPat p) (patSigType t)
|
||||
sigP p t = withEpAnnNotUsed SigPat (builtPat p) (patSigType t)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
sigP p t = SigPat (patSigType t) (builtPat p)
|
||||
#else
|
||||
|
@ -29,11 +29,16 @@ needsPar (NPat _ l _ _) = overLitNeedsParen $ unLoc l
|
||||
needsPar (LitPat l) = litNeedsParen l
|
||||
needsPar (NPat l _ _ _) = overLitNeedsParen $ unLoc l
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
needsPar (ConPat _ _ (PrefixCon _ xs)) = not $ null xs
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
needsPar (ConPat _ _ (PrefixCon xs)) = not $ null xs
|
||||
needsPar (ConPat _ _ (InfixCon _ _)) = True
|
||||
#else
|
||||
needsPar (ConPatIn _ (PrefixCon xs)) = not $ null xs
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
needsPar (ConPat _ _ (InfixCon _ _)) = True
|
||||
#else
|
||||
needsPar (ConPatIn _ (InfixCon _ _)) = True
|
||||
needsPar ConPatOut{} = True
|
||||
#endif
|
||||
@ -46,5 +51,5 @@ needsPar SigPatOut{} = True
|
||||
needsPar _ = False
|
||||
|
||||
parPat :: Pat' -> Pat'
|
||||
parPat = noExt ParPat . builtPat
|
||||
parPat = withEpAnnNotUsed ParPat . builtPat
|
||||
|
||||
|
@ -17,6 +17,10 @@ import GHC.Driver.Session
|
||||
import GHC.Utils.Outputable
|
||||
import System.IO
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Driver.Ppr (printForUser, showPpr)
|
||||
#endif
|
||||
|
||||
hPutPpr :: Outputable a => Handle -> a -> Ghc ()
|
||||
hPutPpr h x = do
|
||||
dflags <- getDynFlags
|
||||
|
@ -21,6 +21,7 @@ import GHC.Hs
|
||||
, HsValBinds
|
||||
, HsMatchContext
|
||||
, IE
|
||||
, LHsExpr
|
||||
, LHsQTyVars
|
||||
, Match
|
||||
, MatchGroup
|
||||
@ -28,12 +29,10 @@ import GHC.Hs
|
||||
, GRHSs
|
||||
, Stmt
|
||||
, ConDecl
|
||||
, HsConDeclDetails
|
||||
, LHsSigType
|
||||
, ImportDecl
|
||||
, LHsSigWcType
|
||||
, LHsWcType
|
||||
, HsImplicitBndrs
|
||||
, TyFamInstDecl
|
||||
#if !MIN_VERSION_ghc(8,8,0)
|
||||
, LHsRecField
|
||||
@ -41,6 +40,11 @@ import GHC.Hs
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
, HsPatSigType
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
, HsConDeclH98Details
|
||||
#else
|
||||
, HsConDeclDetails
|
||||
#endif
|
||||
)
|
||||
import GHC.Hs.Binds (Sig, HsLocalBinds)
|
||||
@ -58,6 +62,16 @@ import RdrName (RdrName)
|
||||
import SrcLoc (SrcSpan, Located, GenLocated(..), mkGeneralSrcSpan)
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Parser.Annotation
|
||||
( SrcSpanAnn'(..)
|
||||
, AnnSortKey(..)
|
||||
, EpAnn(..)
|
||||
, EpAnnComments
|
||||
, emptyComments
|
||||
)
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Types.Basic (PromotionFlag(..))
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
@ -67,11 +81,12 @@ import GHC.Hs.Type (Promoted(..))
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
import GHC.Hs.Extension (NoExtField(NoExtField))
|
||||
import qualified GHC.Hs as GHC
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
import GHC.Hs.Extension (NoExt(NoExt))
|
||||
import qualified GHC.Hs.Extension as GHC
|
||||
#else
|
||||
import PlaceHolder(PlaceHolder(..))
|
||||
import qualified HsExtension as GHC
|
||||
import qualified PlaceHolder as GHC
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
@ -80,42 +95,78 @@ import GHC.Types.Var (Specificity)
|
||||
|
||||
import GHC.Hs.Extension (GhcPs)
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
noExt :: (NoExtField -> a) -> a
|
||||
noExt = ($ NoExtField)
|
||||
|
||||
noExtOrPlaceHolder :: (NoExtField -> a) -> a
|
||||
noExtOrPlaceHolder = noExt
|
||||
|
||||
#else
|
||||
noExt :: (NoExt -> a) -> a
|
||||
noExt = ($ NoExt)
|
||||
|
||||
noExtOrPlaceHolder :: (NoExt -> a) -> a
|
||||
noExtOrPlaceHolder = noExt
|
||||
type NoExtField = GHC.NoExtField
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
type NoExtField = GHC.NoExt
|
||||
#endif
|
||||
|
||||
withPlaceHolder :: a -> a
|
||||
withPlaceHolder = id
|
||||
|
||||
withPlaceHolders :: a -> a
|
||||
withPlaceHolders = id
|
||||
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
noExt :: (NoExtField -> a) -> a
|
||||
noExt = ($ GHC.NoExtField)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
noExt :: (NoExtField -> a) -> a
|
||||
noExt = ($ GHC.NoExt)
|
||||
#else
|
||||
|
||||
noExt :: a -> a
|
||||
noExt = id
|
||||
#endif
|
||||
|
||||
noExtOrPlaceHolder :: (PlaceHolder -> a) -> a
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
noExtOrPlaceHolder :: (NoExtField -> a) -> a
|
||||
noExtOrPlaceHolder = noExt
|
||||
#else
|
||||
noExtOrPlaceHolder :: (GHC.PlaceHolder -> a) -> a
|
||||
noExtOrPlaceHolder = withPlaceHolder
|
||||
#endif
|
||||
|
||||
withPlaceHolder :: (PlaceHolder -> a) -> a
|
||||
withPlaceHolder = ($ PlaceHolder)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
withEpAnnNotUsed :: (EpAnn ann -> a) -> a
|
||||
withEpAnnNotUsed = ($ EpAnnNotUsed)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
withEpAnnNotUsed :: (NoExtField -> a) -> a
|
||||
withEpAnnNotUsed = noExt
|
||||
#else
|
||||
withEpAnnNotUsed :: a -> a
|
||||
withEpAnnNotUsed = id
|
||||
#endif
|
||||
|
||||
withPlaceHolders :: ([PlaceHolder] -> a) -> a
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
withNoAnnSortKey :: (AnnSortKey -> a) -> a
|
||||
withNoAnnSortKey = ($ NoAnnSortKey)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
withNoAnnSortKey :: (NoExtField -> a) -> a
|
||||
withNoAnnSortKey = noExt
|
||||
#else
|
||||
withNoAnnSortKey :: a -> a
|
||||
withNoAnnSortKey = id
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
withEmptyEpAnnComments :: (EpAnnComments -> a) -> a
|
||||
withEmptyEpAnnComments = ($ emptyComments)
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
withEmptyEpAnnComments :: (NoExtField -> a) -> a
|
||||
withEmptyEpAnnComments = noExt
|
||||
#else
|
||||
withEmptyEpAnnComments :: a -> a
|
||||
withEmptyEpAnnComments = id
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
withPlaceHolder :: a -> a
|
||||
withPlaceHolder = id
|
||||
#else
|
||||
withPlaceHolder :: (GHC.PlaceHolder -> a) -> a
|
||||
withPlaceHolder = ($ GHC.PlaceHolder)
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
withPlaceHolders :: a -> a
|
||||
withPlaceHolders = id
|
||||
#else
|
||||
withPlaceHolders :: ([GHC.PlaceHolder] -> a) -> a
|
||||
withPlaceHolders = ($ [])
|
||||
|
||||
#endif
|
||||
|
||||
builtSpan :: SrcSpan
|
||||
@ -124,10 +175,27 @@ builtSpan = mkGeneralSrcSpan "<ghc-source-gen>"
|
||||
builtLoc :: e -> Located e
|
||||
builtLoc = L builtSpan
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
type SrcSpanAnn ann = GHC.SrcSpanAnn' (EpAnn ann)
|
||||
#else
|
||||
type SrcSpanAnn ann = SrcSpan
|
||||
#endif
|
||||
|
||||
mkLocated :: a -> GenLocated (SrcSpanAnn ann) a
|
||||
mkLocated = L (toAnn builtSpan)
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
toAnn = SrcSpanAnn EpAnnNotUsed
|
||||
#else
|
||||
toAnn = id
|
||||
#endif
|
||||
|
||||
-- In GHC-8.8.* (but not >=8.10 or <=8.6), source locations for Pat aren't
|
||||
-- stored in each node, and LPat is a synonym for Pat.
|
||||
builtPat :: Pat' -> LPat'
|
||||
#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
builtPat = mkLocated
|
||||
#elif MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,0)
|
||||
builtPat = id
|
||||
#else
|
||||
builtPat = builtLoc
|
||||
@ -182,6 +250,8 @@ type Pat' = Pat GhcPs
|
||||
-- * 'GHC.SourceGen.Lit.HasLit'
|
||||
type HsExpr' = HsExpr GhcPs
|
||||
|
||||
type LHsExpr' = LHsExpr GhcPs
|
||||
|
||||
-- | A Haskell declaration, as it is represented after the parsing step.
|
||||
--
|
||||
-- Instances:
|
||||
@ -234,11 +304,15 @@ type Match' = Match GhcPs
|
||||
type MatchGroup' = MatchGroup GhcPs
|
||||
type GRHS' = GRHS GhcPs
|
||||
type GRHSs' = GRHSs GhcPs
|
||||
type Stmt' = Stmt GhcPs (Located HsExpr')
|
||||
type Stmt' = Stmt GhcPs LHsExpr'
|
||||
type HsOverLit' = HsOverLit GhcPs
|
||||
type LHsQTyVars' = LHsQTyVars GhcPs
|
||||
type ConDecl' = ConDecl GhcPs
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
type HsConDeclDetails' = HsConDeclH98Details GhcPs
|
||||
#else
|
||||
type HsConDeclDetails' = HsConDeclDetails GhcPs
|
||||
#endif
|
||||
type LHsSigType' = LHsSigType GhcPs
|
||||
type ImportDecl' = ImportDecl GhcPs
|
||||
type LHsSigWcType' = LHsSigWcType GhcPs
|
||||
@ -247,7 +321,6 @@ type HsDerivingClause' = HsDerivingClause GhcPs
|
||||
type LHsRecField' arg = LHsRecField GhcPs arg
|
||||
type LHsRecUpdField' = LHsRecUpdField GhcPs
|
||||
type LPat' = LPat GhcPs
|
||||
type HsImplicitBndrs' = HsImplicitBndrs GhcPs
|
||||
type TyFamInstDecl' = TyFamInstDecl GhcPs
|
||||
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
@ -261,3 +334,9 @@ type HsPatSigType' = HsPatSigType GhcPs
|
||||
#else
|
||||
type HsPatSigType' = LHsSigWcType'
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
type LIdP = GHC.LIdP GHC.GhcPs
|
||||
#else
|
||||
type LIdP = Located (GHC.IdP GHC.GhcPs)
|
||||
#endif
|
||||
|
@ -36,7 +36,7 @@ import GHC.SourceGen.Type.Internal
|
||||
|
||||
-- | A promoted name, for example from the @DataKinds@ extension.
|
||||
tyPromotedVar :: RdrNameStr -> HsType'
|
||||
tyPromotedVar = noExt HsTyVar promoted . typeRdrName
|
||||
tyPromotedVar = withEpAnnNotUsed HsTyVar promoted . typeRdrName
|
||||
|
||||
stringTy :: String -> HsType'
|
||||
stringTy = noExt HsTyLit . noSourceText HsStrTy . fromString
|
||||
@ -45,15 +45,15 @@ numTy :: Integer -> HsType'
|
||||
numTy = noExt HsTyLit . noSourceText HsNumTy
|
||||
|
||||
listTy :: HsType' -> HsType'
|
||||
listTy = noExt HsListTy . builtLoc
|
||||
listTy = withEpAnnNotUsed HsListTy . mkLocated
|
||||
|
||||
listPromotedTy :: [HsType'] -> HsType'
|
||||
-- Lists of two or more elements don't need the explicit tick (`'`).
|
||||
-- But for consistency, just always add it.
|
||||
listPromotedTy = withPlaceHolder (noExt HsExplicitListTy promoted) . map builtLoc
|
||||
listPromotedTy = withPlaceHolder (withEpAnnNotUsed HsExplicitListTy promoted) . map mkLocated
|
||||
|
||||
tuplePromotedTy :: [HsType'] -> HsType'
|
||||
tuplePromotedTy = withPlaceHolders (noExt HsExplicitTupleTy) . map builtLoc
|
||||
tuplePromotedTy = withPlaceHolders (withEpAnnNotUsed HsExplicitTupleTy) . map mkLocated
|
||||
|
||||
-- | A function type.
|
||||
--
|
||||
@ -61,11 +61,11 @@ tuplePromotedTy = withPlaceHolders (noExt HsExplicitTupleTy) . map builtLoc
|
||||
-- > =====
|
||||
-- > var "a" --> var "b"
|
||||
(-->) :: HsType' -> HsType' -> HsType'
|
||||
a --> b = noExt HsFunTy
|
||||
a --> b = withEpAnnNotUsed HsFunTy
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
(HsUnrestrictedArrow NormalSyntax)
|
||||
#endif
|
||||
(parenthesizeTypeForFun $ builtLoc a) (builtLoc b)
|
||||
(parenthesizeTypeForFun $ mkLocated a) (mkLocated b)
|
||||
|
||||
infixr 0 -->
|
||||
|
||||
@ -75,16 +75,18 @@ infixr 0 -->
|
||||
-- > =====
|
||||
-- > forall' [bvar "a"] $ var "T" @@ var "a"
|
||||
forall' :: [HsTyVarBndrS'] -> HsType' -> HsType'
|
||||
forall' ts = noExt HsForAllTy
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
(mkHsForAllInvisTele (map builtLoc ts))
|
||||
forall' ts = noExt hsForAllTy (map mkLocated ts) . mkLocated
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
hsForAllTy x = HsForAllTy x . withEpAnnNotUsed mkHsForAllInvisTele
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
hsForAllTy x = HsForAllTy x . mkHsForAllInvisTele
|
||||
#elif MIN_VERSION_ghc(8,10,0)
|
||||
fvf = ForallInvis -- "Invisible" forall, i.e., with a dot
|
||||
hsForAllTy x = HsForAllTy x fvf
|
||||
#else
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
ForallInvis -- "Invisible" forall, i.e., with a dot
|
||||
hsForAllTy = HsForAllTy
|
||||
#endif
|
||||
(map builtLoc ts)
|
||||
#endif
|
||||
. builtLoc
|
||||
|
||||
-- | Qualify a type with constraints.
|
||||
--
|
||||
@ -92,7 +94,13 @@ forall' ts = noExt HsForAllTy
|
||||
-- > =====
|
||||
-- > [var "F" @@ var "x", var "G" @@ var "x"] ==> var "x"
|
||||
(==>) :: [HsType'] -> HsType' -> HsType'
|
||||
(==>) cs = noExt HsQualTy (builtLoc (map builtLoc cs)) . builtLoc
|
||||
(==>) cs = hsQualTy (mkLocated (map mkLocated cs)) . mkLocated
|
||||
where
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
hsQualTy = noExt HsQualTy . Just
|
||||
#else
|
||||
hsQualTy = noExt HsQualTy
|
||||
#endif
|
||||
|
||||
infixr 0 ==>
|
||||
|
||||
@ -102,8 +110,8 @@ infixr 0 ==>
|
||||
-- > =====
|
||||
-- > kindedVar "x" (var "A")
|
||||
kindedVar :: OccNameStr -> HsType' -> HsTyVarBndr'
|
||||
kindedVar v t = noExt KindedTyVar
|
||||
kindedVar v t = withEpAnnNotUsed KindedTyVar
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
()
|
||||
#endif
|
||||
(typeRdrName $ UnqualStr v) (builtLoc t)
|
||||
(typeRdrName $ UnqualStr v) (mkLocated t)
|
||||
|
@ -7,12 +7,14 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GHC.SourceGen.Type.Internal where
|
||||
|
||||
import GHC.Hs (GhcPs)
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.Hs.Type as Types
|
||||
import GHC.Types.SrcLoc (Located, unLoc)
|
||||
import GHC.Types.SrcLoc (unLoc)
|
||||
#else
|
||||
import GHC.Hs.Type as Types
|
||||
import SrcLoc (Located, unLoc)
|
||||
import SrcLoc (unLoc)
|
||||
#endif
|
||||
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
@ -20,13 +22,14 @@ import GHC.SourceGen.Syntax.Internal
|
||||
mkQTyVars :: [HsTyVarBndr'] -> LHsQTyVars'
|
||||
mkQTyVars vars = withPlaceHolder
|
||||
$ noExt (withPlaceHolder HsQTvs)
|
||||
$ map builtLoc vars
|
||||
$ map mkLocated vars
|
||||
|
||||
sigType :: HsType' -> LHsSigType'
|
||||
sigType = implicitBndrs . builtLoc
|
||||
|
||||
implicitBndrs :: t -> HsImplicitBndrs' t
|
||||
implicitBndrs = withPlaceHolder . noExt (withPlaceHolder Types.HsIB)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
sigType = mkLocated . noExt HsSig (noExt HsOuterImplicit) . mkLocated
|
||||
#else
|
||||
sigType = withPlaceHolder . noExt (withPlaceHolder Types.HsIB) . builtLoc
|
||||
#endif
|
||||
|
||||
|
||||
-- TODO: GHC >= 8.6 provides parenthesizeHsType. For consistency with
|
||||
@ -34,7 +37,7 @@ implicitBndrs = withPlaceHolder . noExt (withPlaceHolder Types.HsIB)
|
||||
-- Once we stop supporting GHC-8.4, we can switch to that implementation.
|
||||
|
||||
parenthesizeTypeForApp, parenthesizeTypeForOp, parenthesizeTypeForFun
|
||||
:: Located HsType' -> Located HsType'
|
||||
:: LHsType GhcPs -> LHsType GhcPs
|
||||
parenthesizeTypeForApp t
|
||||
| needsParenForApp (unLoc t) = parTy t
|
||||
| otherwise = t
|
||||
@ -59,17 +62,19 @@ needsParenForApp t = case t of
|
||||
HsAppTy {} -> True
|
||||
_ -> needsParenForOp t
|
||||
|
||||
parTy :: Located HsType' -> Located HsType'
|
||||
parTy = builtLoc . noExt HsParTy
|
||||
parTy :: LHsType GhcPs -> LHsType GhcPs
|
||||
parTy = mkLocated . withEpAnnNotUsed HsParTy
|
||||
|
||||
sigWcType :: HsType' -> LHsSigWcType'
|
||||
sigWcType = noExt (withPlaceHolder Types.HsWC) . sigType
|
||||
|
||||
wcType :: HsType' -> LHsWcType'
|
||||
wcType = noExt (withPlaceHolder Types.HsWC) . builtLoc
|
||||
wcType = noExt (withPlaceHolder Types.HsWC) . mkLocated
|
||||
|
||||
patSigType :: HsType' -> HsPatSigType'
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
patSigType = withEpAnnNotUsed mkHsPatSigType . mkLocated
|
||||
#elif MIN_VERSION_ghc(9,0,0)
|
||||
patSigType = mkHsPatSigType . builtLoc
|
||||
#else
|
||||
patSigType = sigWcType
|
||||
|
@ -4,31 +4,11 @@
|
||||
# license that can be found in the LICENSE file or at
|
||||
# https://developers.google.com/open-source/licenses/bsd
|
||||
|
||||
resolver: ghc-9.0.1
|
||||
resolver: nightly-2021-11-14
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ghc-show-ast
|
||||
|
||||
allow-newer: true
|
||||
|
||||
ghc-options:
|
||||
"$locals": -Wall -Werror
|
||||
|
||||
extra-deps:
|
||||
- QuickCheck-2.14.2@sha256:4ce29211223d5e6620ebceba34a3ca9ccf1c10c0cf387d48aea45599222ee5aa,7736
|
||||
- ghc-paths-0.1.0.12@sha256:afdfdb6584f39e821b2b7130e12007bf3ad87401d86f5105eead059c150dc81d,657
|
||||
- tasty-1.4.1@sha256:69e90e965543faf0fc2c8e486d6c1d8cf81fd108e2c4541234c41490f392f94f,2638
|
||||
- tasty-hunit-0.10.0.3@sha256:ba774024f3a26100c559dbef41e030bdf443408ed848691f7b9aa85b6fb218c3,1545
|
||||
- tasty-quickcheck-0.10.1.2@sha256:45c8125e5de19570359784def5946dec759b7431e3beccc61cd09d661daf19ed,1613
|
||||
- ansi-terminal-0.11@sha256:97470250c92aae14c4c810d7f664c532995ba8910e2ad797b29f22ad0d2d0194,3307
|
||||
- call-stack-0.4.0@sha256:ac44d2c00931dc20b01750da8c92ec443eb63a7231e8550188cb2ac2385f7feb,1200
|
||||
- clock-0.8.2@sha256:473ffd59765cc67634bdc55b63c699a85addf3a024089073ec2a862881e83e2a,4313
|
||||
- optparse-applicative-0.16.1.0@sha256:16ebd7054b2265c1aad16c1d19dc503695fbfc67b35203d9952fd577d08c0110,4982
|
||||
- random-1.2.0@sha256:195506fedaa7c31c1fa2a747e9b49b4a5d1f0b09dd8f1291f23a771656faeec3,6097
|
||||
- splitmix-0.1.0.3@sha256:fc3aae74c467f4b608050bef53aec17904a618731df9407e655d8f3bf8c32d5c,6049
|
||||
- tagged-0.8.6.1@sha256:29c67d98a4404607f024750ab9c7210dadcbbef4e1944c48c52902f2071b2662,2874
|
||||
- unbounded-delays-0.1.1.1@sha256:d7a2a49f15bdff2a8bdbd76f9d204580ea4be5a9def500c6371d51d8111cbcbe,1209
|
||||
- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3,1998
|
||||
- ansi-wl-pprint-0.6.9@sha256:20d30674f137d43aa0279c2c2cc5e45a5f1c3c57e301852494906158b6313bf7,2388
|
||||
- colour-2.3.6@sha256:ebdcbf15023958838a527e381ab3c3b1e99ed12d1b25efeb7feaa4ad8c37664a,2378
|
||||
- transformers-compat-0.7@sha256:c4cc2d01c4e490ba680e9a0b607a1a790137856a6b3af12f8bdc7788a567bcf5,5572
|
15
stack-9.2.yaml
Normal file
15
stack-9.2.yaml
Normal file
@ -0,0 +1,15 @@
|
||||
# Copyright 2019 Google LLC
|
||||
#
|
||||
# Use of this source code is governed by a BSD-style
|
||||
# license that can be found in the LICENSE file or at
|
||||
# https://developers.google.com/open-source/licenses/bsd
|
||||
|
||||
resolver: nightly-2021-11-14
|
||||
compiler: ghc-9.2.1
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ghc-show-ast
|
||||
|
||||
ghc-options:
|
||||
"$locals": -Wall -Werror
|
Loading…
Reference in New Issue
Block a user