diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Changelog for haskell-syntax +# 0.4.0.0 + +## Breaking Changes +- Functions defining types and classes now take their + type parameters as `HsTyVarBndr'` rather than `OccNameStr`. + To construct a `HsTyVarBndr'`, use either `bvar` or `kindedVar`. + Affects: `class'`, `type'`, `newtype'`, and `data'`. +- Remove support for ghc-8.2.*. + +## Other Changes +- Add support for ghc-8.10. +- Add `kindedVar`. +- Add `tuplePromotedTy`. +- Add `from`, `fromTo`, `fromThen`, `fromThenTo`. +- Add `listComp`. + ## 0.3.0.0 - Add `occNameToStr` and `nameToStr` to convert from the GHC types. - Make `listPromotedTy` emit the promoted form `'[..]`, diff --git a/compat/GHC/Hs.hs b/compat/GHC/Hs.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs.hs @@ -0,0 +1,2 @@ +module GHC.Hs (module HsSyn) where +import HsSyn diff --git a/compat/GHC/Hs/Binds.hs b/compat/GHC/Hs/Binds.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Binds.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Binds (module HsBinds) where +import HsBinds diff --git a/compat/GHC/Hs/Decls.hs b/compat/GHC/Hs/Decls.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Decls.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Decls (module HsDecls) where +import HsDecls diff --git a/compat/GHC/Hs/Expr.hs b/compat/GHC/Hs/Expr.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Expr.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Expr (module HsExpr) where +import HsExpr diff --git a/compat/GHC/Hs/Extension.hs b/compat/GHC/Hs/Extension.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Extension.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Extension (module HsExtension) where +import HsExtension diff --git a/compat/GHC/Hs/ImpExp.hs b/compat/GHC/Hs/ImpExp.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/ImpExp.hs @@ -0,0 +1,2 @@ +module GHC.Hs.ImpExp (module HsImpExp) where +import HsImpExp diff --git a/compat/GHC/Hs/Lit.hs b/compat/GHC/Hs/Lit.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Lit.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Lit (module HsLit) where +import HsLit diff --git a/compat/GHC/Hs/Pat.hs b/compat/GHC/Hs/Pat.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Pat.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Pat (module HsPat) where +import HsPat diff --git a/compat/GHC/Hs/Types.hs b/compat/GHC/Hs/Types.hs new file mode 100644 --- /dev/null +++ b/compat/GHC/Hs/Types.hs @@ -0,0 +1,2 @@ +module GHC.Hs.Types (module HsTypes) where +import HsTypes diff --git a/ghc-source-gen.cabal b/ghc-source-gen.cabal --- a/ghc-source-gen.cabal +++ b/ghc-source-gen.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: df3442cc801aef91cf974539ddc9628924856c16db7eaddc3ca0811136afa6e2 +-- hash: 5ce0ceef64535fb124b604d3193e37b6dc89ea437af2ac6cbe6c631afad662ed name: ghc-source-gen -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Constructs Haskell syntax trees for the GHC API. description: @ghc-source-gen@ is a library for generating Haskell source code. It uses the library @@ -60,7 +60,20 @@ default-extensions: DataKinds FlexibleInstances TypeSynonymInstances build-depends: base >=4.7 && <5 - , ghc >=8.2 && <8.9 + , ghc >=8.4 && <8.11 + if impl(ghc<8.10) + other-modules: + GHC.Hs + GHC.Hs.Binds + GHC.Hs.Decls + GHC.Hs.Expr + GHC.Hs.Extension + GHC.Hs.ImpExp + GHC.Hs.Lit + GHC.Hs.Pat + GHC.Hs.Types + hs-source-dirs: + compat default-language: Haskell2010 test-suite name_test @@ -75,7 +88,7 @@ build-depends: QuickCheck >=2.10 && <2.14 , base >=4.7 && <5 - , ghc >=8.2 && <8.9 + , ghc >=8.4 && <8.11 , ghc-source-gen , tasty >=1.0 && <1.3 , tasty-hunit ==0.10.* @@ -93,7 +106,7 @@ default-extensions: DataKinds FlexibleInstances TypeSynonymInstances build-depends: base >=4.7 && <5 - , ghc >=8.2 && <8.9 + , ghc >=8.4 && <8.11 , ghc-paths ==0.1.* , ghc-source-gen , tasty >=1.0 && <1.3 @@ -111,7 +124,7 @@ default-extensions: DataKinds FlexibleInstances TypeSynonymInstances build-depends: base >=4.7 && <5 - , ghc >=8.2 && <8.9 + , ghc >=8.4 && <8.11 , ghc-paths ==0.1.* , ghc-source-gen , tasty >=1.0 && <1.3 diff --git a/src/GHC/SourceGen/Binds.hs b/src/GHC/SourceGen/Binds.hs --- a/src/GHC/SourceGen/Binds.hs +++ b/src/GHC/SourceGen/Binds.hs @@ -45,9 +45,9 @@ ) where import BasicTypes (LexicalFixity(..)) -import HsBinds -import HsExpr -import HsTypes +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.Types import TcEvidence (HsWrapper(WpHole)) import GHC.SourceGen.Binds.Internal diff --git a/src/GHC/SourceGen/Binds/Internal.hs b/src/GHC/SourceGen/Binds/Internal.hs --- a/src/GHC/SourceGen/Binds/Internal.hs +++ b/src/GHC/SourceGen/Binds/Internal.hs @@ -9,9 +9,9 @@ import BasicTypes (Origin(Generated)) import Bag (listToBag) -import HsBinds -import HsDecls -import HsExpr (MatchGroup(..), Match(..), GRHSs(..)) +import GHC.Hs.Binds +import GHC.Hs.Decls +import GHC.Hs.Expr (MatchGroup(..), Match(..), GRHSs(..)) import SrcLoc (Located) #if !MIN_VERSION_ghc(8,6,0) @@ -88,11 +88,6 @@ mkMatch :: RawMatch -> Match' (Located HsExpr') mkMatch r = noExt Match context (map builtPat $ map parenthesize $ rawMatchPats r) -#if !MIN_VERSION_ghc(8,4,0) - -- The GHC docs say: "A type signature for the result of the match." - -- The parsing step produces 'Nothing' for this field. - Nothing -#endif (mkGRHSs $ rawMatchGRHSs r) mkGRHSs :: RawGRHSs -> GRHSs' (Located HsExpr') diff --git a/src/GHC/SourceGen/Decl.hs b/src/GHC/SourceGen/Decl.hs --- a/src/GHC/SourceGen/Decl.hs +++ b/src/GHC/SourceGen/Decl.hs @@ -50,9 +50,9 @@ import BasicTypes (DerivStrategy(..)) #endif import Bag (listToBag) -import HsBinds -import HsDecls -import HsTypes +import GHC.Hs.Binds +import GHC.Hs.Decls +import GHC.Hs.Types ( ConDeclField(..) , FieldOcc(..) , HsConDetails(..) @@ -66,8 +66,10 @@ ) import SrcLoc (Located) -#if MIN_VERSION_ghc(8,6,0) -import HsExtension (NoExt(NoExt)) +#if 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)) #else import PlaceHolder (PlaceHolder(..)) #endif @@ -128,7 +130,7 @@ -- > in class' -- > [var "Real" @@ a, var "Enum" @@ a] -- > "Integral" --- > ["a"] +-- > [bvar "a"] -- > [ typeSig "divMod" $ a --> a --> tuple [a, a] -- > , typeSig "div" $ a --> a --> a -- > , funBind "div" @@ -138,13 +140,15 @@ class' :: [HsType'] -- ^ Context -> OccNameStr -- ^ Class name - -> [OccNameStr] -- ^ Type parameters + -> [HsTyVarBndr'] -- ^ Type parameters -> [ClassDecl] -- ^ Class declarations -> HsDecl' class' context name vars decls = noExt TyClD $ ClassDecl { tcdCtxt = builtLoc $ map builtLoc context -#if MIN_VERSION_ghc(8,6,0) +#if MIN_VERSION_ghc(8,10,0) + , tcdCExt = NoExtField +#elif MIN_VERSION_ghc(8,6,0) , tcdCExt = NoExt #else , tcdFVs = PlaceHolder @@ -193,7 +197,9 @@ instance' :: HsType' -> [RawInstDecl] -> HsDecl' instance' ty decls = noExt InstD $ noExt ClsInstD $ ClsInstDecl { cid_poly_ty = sigType ty -#if MIN_VERSION_ghc(8,6,0) +#if 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] @@ -222,7 +228,6 @@ -- > tyFamInst "Elt" [var "String"] (var "Char") tyFamInst :: HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t tyFamInst name params ty = tyFamInstD -#if MIN_VERSION_ghc(8,4,0) $ TyFamInstDecl $ implicitBndrs $ noExt FamEqn (typeRdrName name) @@ -234,20 +239,13 @@ #endif Prefix (builtLoc ty) -#else - $ withPlaceHolder $ TyFamInstDecl - $ builtLoc $ TyFamEqn (typeRdrName name) - (implicitBndrs $ map builtLoc params) - Prefix - (builtLoc ty) -#endif -- | Declares a type synonym. -- -- > type A a b = B b a -- > ===== --- > type' "A" ["a", "b"] $ var "B" @@ var "b" @@ var "a" -type' :: OccNameStr -> [OccNameStr] -> HsType' -> HsDecl' +-- > 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) (mkQTyVars vars) @@ -257,7 +255,7 @@ newOrDataType :: NewOrData -> OccNameStr - -> [OccNameStr] + -> [HsTyVarBndr'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl' @@ -276,10 +274,10 @@ -- -- > newtype Const a b = Const a deriving Eq -- > ===== --- > newtype' "Const" ["a", "b"] +-- > newtype' "Const" [bvar "a", bvar "b"] -- > (conDecl "Const" [var "a"]) -- > [var "Show"] -newtype' :: OccNameStr -> [OccNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl' +newtype' :: OccNameStr -> [HsTyVarBndr'] -> ConDecl' -> [HsDerivingClause'] -> HsDecl' newtype' name vars conD = newOrDataType NewType name vars [conD] -- | A data declaration. @@ -287,12 +285,12 @@ -- > data Either a b = Left a | Right b -- > deriving Show -- > ===== --- > data' "Either" ["a", "b"] +-- > data' "Either" [bvar "a", bvar "b"] -- > [ conDecl "Left" [var "a"] -- > , conDecl "Right" [var "b"] -- > ] -- > [var "Show"] -data' :: OccNameStr -> [OccNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl' +data' :: OccNameStr -> [HsTyVarBndr'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl' data' = newOrDataType DataType -- | Declares a Haskell-98-style prefix constructor for a data or type @@ -441,12 +439,7 @@ patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl' patSynBind n ns p = bindB $ noExt PatSynBind $ withPlaceHolder (noExt PSB (valueRdrName $ unqual n)) -#if MIN_VERSION_ghc(8,4,0) - (PrefixCon -#else - (PrefixPatSyn -#endif - (map (valueRdrName . unqual) ns)) + (PrefixCon (map (valueRdrName . unqual) ns)) (builtPat p) ImplicitBidirectional diff --git a/src/GHC/SourceGen/Expr.hs b/src/GHC/SourceGen/Expr.hs --- a/src/GHC/SourceGen/Expr.hs +++ b/src/GHC/SourceGen/Expr.hs @@ -16,16 +16,22 @@ , if' , multiIf , do' + , listComp , Stmt' , (@::@) , tyApp , recordConE , recordUpd + , from + , fromThen + , fromTo + , fromThenTo ) where -import HsExpr -import HsPat (HsRecField'(..), HsRecFields(..)) -import HsTypes (FieldOcc(..), AmbiguousFieldOcc(..)) +import GHC.Hs.Expr +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Pat (HsRecField'(..), HsRecFields(..)) +import GHC.Hs.Types (FieldOcc(..), AmbiguousFieldOcc(..)) import Data.String (fromString) import SrcLoc (unLoc, GenLocated(..), Located) @@ -104,6 +110,20 @@ #endif parenthesizeIfLet s = s +-- | A list comprehension expression. +-- +-- > [x * 2 | x <- [1 .. 10], even x] +-- > ===== +-- > listComp (op (bvar "x") "*" (int 2)) +-- > [ bvar "x" <-- fromTo (int 1) (int 10) +-- > , stmt $ var "even" @@ bvar "x" +-- > ] +listComp :: HsExpr' -> [Stmt'] -> HsExpr' +listComp lastExpr stmts = + let lastStmt = noExt LastStmt (builtLoc lastExpr) False noSyntaxExpr + in withPlaceHolder . noExt HsDo ListComp . builtLoc . map builtLoc $ + stmts ++ [lastStmt] + -- | A type constraint on an expression. -- -- > e :: t @@ -187,3 +207,44 @@ } withPlaceHolder4 = withPlaceHolder . withPlaceHolder . withPlaceHolder . withPlaceHolder + +arithSeq :: ArithSeqInfo GhcPs -> HsExpr' +arithSeq = +#if !MIN_VERSION_ghc(8,6,0) + ArithSeq noPostTcExpr Nothing +#else + noExt ArithSeq Nothing +#endif + +-- | An arithmetic sequence expression with a start value. +-- +-- > [a ..] +-- > ===== +-- > from (var "a") +from :: HsExpr' -> HsExpr' +from from' = arithSeq $ From (builtLoc from') + +-- | An arithmetic sequence expression with a start and a step values. +-- +-- > [a, b ..] +-- > ===== +-- > fromThen (var "a") (var "b") +fromThen :: HsExpr' -> HsExpr' -> HsExpr' +fromThen from' then' = arithSeq $ FromThen (builtLoc from') (builtLoc then') + +-- | An arithmetic sequence expression with a start and an end values. +-- +-- > [a .. b] +-- > ===== +-- > fromTo (var "a") (var "b") +fromTo :: HsExpr' -> HsExpr' -> HsExpr' +fromTo from' to = arithSeq $ FromTo (builtLoc from') (builtLoc to) + +-- | An arithmetic sequence expression with a start, a step, and an end values. +-- +-- > [a, b .. c] +-- > ===== +-- > fromThenTo (var "a") (var "b") (var "c") +fromThenTo :: HsExpr' -> HsExpr' -> HsExpr' -> HsExpr' +fromThenTo from' then' to = + arithSeq $ FromThenTo (builtLoc from') (builtLoc then') (builtLoc to) diff --git a/src/GHC/SourceGen/Expr/Internal.hs b/src/GHC/SourceGen/Expr/Internal.hs --- a/src/GHC/SourceGen/Expr/Internal.hs +++ b/src/GHC/SourceGen/Expr/Internal.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} module GHC.SourceGen.Expr.Internal where -import HsExpr +import GHC.Hs.Expr import SrcLoc (Located, unLoc) import GHC.SourceGen.Lit.Internal diff --git a/src/GHC/SourceGen/Lit.hs b/src/GHC/SourceGen/Lit.hs --- a/src/GHC/SourceGen/Lit.hs +++ b/src/GHC/SourceGen/Lit.hs @@ -4,7 +4,6 @@ -- license that can be found in the LICENSE file or at -- https://developers.google.com/open-source/licenses/bsd -{-# LANGUAGE CPP #-} -- | This module provides combinators for constructing Haskell literals, -- which may be used in either patterns or expressions. module GHC.SourceGen.Lit @@ -18,12 +17,10 @@ ) where import BasicTypes (FractionalLit(..)) -#if MIN_VERSION_ghc(8,4,0) import BasicTypes(IntegralLit(..), SourceText(..)) -#endif -import HsLit -import HsExpr (noExpr, noSyntaxExpr, HsExpr(..)) -import HsPat (Pat(..)) +import GHC.Hs.Lit +import GHC.Hs.Expr (noExpr, noSyntaxExpr, HsExpr(..)) +import GHC.Hs.Pat (Pat(..)) import FastString (fsLit) import GHC.SourceGen.Lit.Internal @@ -52,19 +49,11 @@ int :: HasLit e => Integer -> e int n = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit il) noExpr where -#if MIN_VERSION_ghc(8,4,0) il = HsIntegral $ noSourceText IL (n < 0) n -#else - il = noSourceText HsIntegral n -#endif -- | 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 where -#if MIN_VERSION_ghc(8,4,0) il = FL (SourceText s) (x < 0) x -#else - il = FL s x -#endif s = show (fromRational x :: Double) diff --git a/src/GHC/SourceGen/Lit/Internal.hs b/src/GHC/SourceGen/Lit/Internal.hs --- a/src/GHC/SourceGen/Lit/Internal.hs +++ b/src/GHC/SourceGen/Lit/Internal.hs @@ -4,14 +4,11 @@ -- license that can be found in the LICENSE file or at -- https://developers.google.com/open-source/licenses/bsd -{-# LANGUAGE CPP #-} module GHC.SourceGen.Lit.Internal where import BasicTypes (SourceText(NoSourceText), FractionalLit(..)) -#if MIN_VERSION_ghc(8,4,0) import BasicTypes (IntegralLit(..)) -#endif -import HsLit +import GHC.Hs.Lit import GHC.SourceGen.Syntax.Internal noSourceText :: (SourceText -> a) -> a @@ -26,11 +23,6 @@ overLitNeedsParen :: HsOverLit' -> Bool overLitNeedsParen = needs . ol_val where -#if MIN_VERSION_ghc(8,4,0) needs (HsIntegral x) = il_neg x needs (HsFractional x) = fl_neg x -#else - needs (HsIntegral _ x) = x < 0 - needs (HsFractional x) = fl_value x < 0 -#endif needs _ = False diff --git a/src/GHC/SourceGen/Module.hs b/src/GHC/SourceGen/Module.hs --- a/src/GHC/SourceGen/Module.hs +++ b/src/GHC/SourceGen/Module.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright 2019 Google LLC -- -- Use of this source code is governed by a BSD-style @@ -17,6 +18,7 @@ , import' , exposing , hiding + , source -- * Imported/exported things , IE' , thingAll @@ -24,10 +26,13 @@ , moduleContents ) where -import HsImpExp (LIEWrappedName, IEWildcard(..), IEWrappedName(..), IE(..)) -import HsSyn +import GHC.Hs.ImpExp (LIEWrappedName, IEWildcard(..), IEWrappedName(..), IE(..)) +import GHC.Hs ( HsModule(..) , ImportDecl(..) +#if MIN_VERSION_ghc(8,10,0) + , ImportDeclQualifiedStyle(..) +#endif ) import RdrName (RdrName) @@ -52,7 +57,13 @@ } qualified' :: ImportDecl' -> ImportDecl' -qualified' d = d { ideclQualified = True } +qualified' d = d { ideclQualified = +#if MIN_VERSION_ghc(8,10,0) + QualifiedPre +#else + True +#endif +} as' :: ImportDecl' -> ModuleNameStr -> ImportDecl' as' d m = d { ideclAs = Just (builtLoc $ unModuleNameStr m) } @@ -60,7 +71,13 @@ import' :: ModuleNameStr -> ImportDecl' import' m = noSourceText (noExt ImportDecl) (builtLoc $ unModuleNameStr m) - Nothing False False False False Nothing Nothing + Nothing False False +#if MIN_VERSION_ghc(8,10,0) + NotQualified +#else + False +#endif + False Nothing Nothing exposing :: ImportDecl' -> [IE'] -> ImportDecl' exposing d ies = d @@ -69,6 +86,10 @@ hiding :: ImportDecl' -> [IE'] -> ImportDecl' hiding d ies = d { ideclHiding = Just (True, builtLoc $ map builtLoc ies) } + +-- | Adds the @{-# SOURCE #-}@ pragma to an import. +source :: ImportDecl' -> ImportDecl' +source d = d { ideclSource = True } -- | Exports all methods and/or constructors. -- diff --git a/src/GHC/SourceGen/Overloaded.hs b/src/GHC/SourceGen/Overloaded.hs --- a/src/GHC/SourceGen/Overloaded.hs +++ b/src/GHC/SourceGen/Overloaded.hs @@ -19,16 +19,16 @@ ) where import BasicTypes (Boxity(..)) -import HsTypes +import GHC.Hs.Types ( HsType(..) , HsTyVarBndr(..) ) -import HsSyn (IE(..), IEWrappedName(..)) +import GHC.Hs (IE(..), IEWrappedName(..)) #if !MIN_VERSION_ghc(8,6,0) import PlaceHolder(PlaceHolder(..)) #endif -import HsSyn +import GHC.Hs ( HsExpr(..) , Pat(..) , HsTupArg(..) diff --git a/src/GHC/SourceGen/Pat.hs b/src/GHC/SourceGen/Pat.hs --- a/src/GHC/SourceGen/Pat.hs +++ b/src/GHC/SourceGen/Pat.hs @@ -18,8 +18,8 @@ , sigP ) where -import HsTypes -import HsPat hiding (LHsRecField') +import GHC.Hs.Types +import GHC.Hs.Pat hiding (LHsRecField') import GHC.SourceGen.Name.Internal import GHC.SourceGen.Pat.Internal @@ -92,7 +92,7 @@ -- > sigPat (bvar "x") (var "y") sigP :: Pat' -> HsType' -> Pat' #if MIN_VERSION_ghc(8,8,0) -sigP p t = noExt SigPat p (sigWcType t) +sigP p t = noExt SigPat (builtPat p) (sigWcType t) #elif MIN_VERSION_ghc(8,6,0) sigP p t = SigPat (sigWcType t) (builtPat p) #else diff --git a/src/GHC/SourceGen/Pat/Internal.hs b/src/GHC/SourceGen/Pat/Internal.hs --- a/src/GHC/SourceGen/Pat/Internal.hs +++ b/src/GHC/SourceGen/Pat/Internal.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} module GHC.SourceGen.Pat.Internal where -import HsPat (Pat(..)) -import HsTypes (HsConDetails(..)) +import GHC.Hs.Pat (Pat(..)) +import GHC.Hs.Types (HsConDetails(..)) import GHC.SourceGen.Lit.Internal (litNeedsParen, overLitNeedsParen) import GHC.SourceGen.Syntax.Internal diff --git a/src/GHC/SourceGen/Syntax/Internal.hs b/src/GHC/SourceGen/Syntax/Internal.hs --- a/src/GHC/SourceGen/Syntax/Internal.hs +++ b/src/GHC/SourceGen/Syntax/Internal.hs @@ -9,7 +9,7 @@ module GHC.SourceGen.Syntax.Internal where -import HsSyn +import GHC.Hs ( HsDecl , HsExpr(..) , HsLit @@ -40,43 +40,55 @@ , LHsRecUpdField #endif ) -import HsBinds (Sig, HsLocalBinds) +import GHC.Hs.Binds (Sig, HsLocalBinds) #if MIN_VERSION_ghc(8,6,0) -import HsDecls (DerivStrategy) +import GHC.Hs.Decls (DerivStrategy) #else import BasicTypes (DerivStrategy) #endif -import HsDecls (HsDerivingClause) -import HsPat +import GHC.Hs.Decls (HsDerivingClause) +import GHC.Hs.Pat import RdrName (RdrName) import SrcLoc (SrcSpan, Located, GenLocated(..), mkGeneralSrcSpan) #if MIN_VERSION_ghc(8,8,0) import BasicTypes (PromotionFlag(..)) #else -import HsTypes (Promoted(..)) +import GHC.Hs.Types (Promoted(..)) #endif -#if MIN_VERSION_ghc(8,6,0) -import HsExtension (NoExt(NoExt)) +#if 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)) #else import PlaceHolder(PlaceHolder(..)) #endif -#if MIN_VERSION_ghc(8,4,0) -import HsExtension (GhcPs) -#endif +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 +#endif withPlaceHolder :: a -> a withPlaceHolder = id +withPlaceHolders :: a -> a +withPlaceHolders = id + #else noExt :: a -> a @@ -88,6 +100,9 @@ withPlaceHolder :: (PlaceHolder -> a) -> a withPlaceHolder = ($ PlaceHolder) +withPlaceHolders :: ([PlaceHolder] -> a) -> a +withPlaceHolders = ($ []) + #endif builtSpan :: SrcSpan @@ -96,10 +111,10 @@ builtLoc :: e -> Located e builtLoc = L builtSpan --- In GHC-8.8, source locations for Pat aren't stored in each node, and --- LPat is a synonym for Pat. +-- 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) +#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,0) builtPat = id #else builtPat = builtLoc @@ -128,11 +143,7 @@ -- * 'GHC.SourceGen.Overloaded.Par' -- * 'GHC.SourceGen.Overloaded.App' -- * 'GHC.SourceGen.Overloaded.HasTuple' -#if MIN_VERSION_ghc(8,4,0) type HsType' = HsType GhcPs -#else -type HsType' = HsType RdrName -#endif -- | A Haskell pattern, as it is represented after the parsing step. -- @@ -143,11 +154,7 @@ -- * 'GHC.SourceGen.Overloaded.HasTuple' -- * 'GHC.SourceGen.Overloaded.HasList' -- * 'GHC.SourceGen.Lit.HasLit' -#if MIN_VERSION_ghc(8,4,0) type Pat' = Pat GhcPs -#else -type Pat' = Pat RdrName -#endif -- | A Haskell expression, as it is represented after the parsing step. -- @@ -160,11 +167,7 @@ -- * 'GHC.SourceGen.Overloaded.HasTuple' -- * 'GHC.SourceGen.Overloaded.HasList' -- * 'GHC.SourceGen.Lit.HasLit' -#if MIN_VERSION_ghc(8,4,0) type HsExpr' = HsExpr GhcPs -#else -type HsExpr' = HsExpr RdrName -#endif -- | A Haskell declaration, as it is represented after the parsing step. -- @@ -172,11 +175,7 @@ -- -- * 'GHC.SourceGen.Binds.HasValBind' -- * 'GHC.SourceGen.Binds.HasPatBind' -#if MIN_VERSION_ghc(8,4,0) type HsDecl' = HsDecl GhcPs -#else -type HsDecl' = HsDecl RdrName -#endif -- | An imported or exported entity, as it is represented after the parsing step. -- @@ -184,25 +183,19 @@ -- -- * 'GHC.SourceGen.Overloaded.BVar' -- * 'GHC.SourceGen.Overloaded.Var' -#if MIN_VERSION_ghc(8,4,0) type IE' = IE GhcPs -#else -type IE' = IE RdrName -#endif -- | A type variable binding, as it is represented after the parsing step. -- +-- Construct with either 'GHC.SourceGen.Overloaded.bVar' (for regular type +-- variables) or `GHC.SourceGen.Type.kindedVar` (for kind signatures). +-- -- Instances: -- -- * 'GHC.SourceGen.Overloaded.BVar' -#if MIN_VERSION_ghc(8,4,0) type HsTyVarBndr' = HsTyVarBndr GhcPs -#else -type HsTyVarBndr' = HsTyVarBndr RdrName -#endif -#if MIN_VERSION_ghc(8,4,0) type HsLit' = HsLit GhcPs type HsModule' = HsModule GhcPs type HsBind' = HsBind GhcPs @@ -229,36 +222,6 @@ type LPat' = LPat GhcPs type HsImplicitBndrs' = HsImplicitBndrs GhcPs type TyFamInstDecl' = TyFamInstDecl GhcPs - -#else -type HsLit' = HsLit -type HsModule' = HsModule RdrName -type HsBind' = HsBind RdrName -type HsLocalBinds' = HsLocalBinds RdrName -type HsValBinds' = HsValBinds RdrName -type Sig' = Sig RdrName -type HsMatchContext' = HsMatchContext RdrName -type Match' = Match RdrName -type MatchGroup' = MatchGroup RdrName -type GRHS' = GRHS RdrName -type GRHSs' = GRHSs RdrName -type Stmt' = Stmt RdrName (Located HsExpr') -type HsOverLit' = HsOverLit RdrName -type LHsQTyVars' = LHsQTyVars RdrName -type ConDecl' = ConDecl RdrName -type HsConDeclDetails' = HsConDeclDetails RdrName -type LHsSigType' = LHsSigType RdrName -type ImportDecl' = ImportDecl RdrName -type LHsSigWcType' = LHsSigWcType RdrName -type LHsWcType' = LHsWcType RdrName -type HsDerivingClause' = HsDerivingClause RdrName -type LHsRecField' arg = LHsRecField RdrName arg -type LHsRecUpdField' = LHsRecUpdField RdrName -type LPat' = LPat RdrName -type HsImplicitBndrs' = HsImplicitBndrs RdrName -type TyFamInstDecl' = TyFamInstDecl RdrName - -#endif #if MIN_VERSION_ghc(8,6,0) type DerivStrategy' = DerivStrategy GhcPs diff --git a/src/GHC/SourceGen/Type.hs b/src/GHC/SourceGen/Type.hs --- a/src/GHC/SourceGen/Type.hs +++ b/src/GHC/SourceGen/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright 2019 Google LLC -- -- Use of this source code is governed by a BSD-style @@ -12,14 +13,16 @@ , numTy , listTy , listPromotedTy + , tuplePromotedTy , (-->) , forall' , HsTyVarBndr' , (==>) + , kindedVar ) where import Data.String (fromString) -import HsTypes +import GHC.Hs.Types import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Lit.Internal (noSourceText) @@ -44,6 +47,9 @@ -- But for consistency, just always add it. listPromotedTy = withPlaceHolder (noExt HsExplicitListTy promoted) . map builtLoc +tuplePromotedTy :: [HsType'] -> HsType' +tuplePromotedTy = withPlaceHolders (noExt HsExplicitTupleTy) . map builtLoc + -- | A function type. -- -- > a -> b @@ -60,7 +66,11 @@ -- > ===== -- > forall' [bvar "a"] $ var "T" @@ var "a" forall' :: [HsTyVarBndr'] -> HsType' -> HsType' -forall' ts = noExt HsForAllTy (map builtLoc ts) . builtLoc +forall' ts = noExt HsForAllTy +#if MIN_VERSION_ghc(8,10,0) + ForallInvis -- "Invisible" forall, i.e., with a dot +#endif + (map builtLoc ts) . builtLoc -- | Qualify a type with constraints. -- @@ -71,3 +81,12 @@ (==>) cs = noExt HsQualTy (builtLoc (map builtLoc cs)) . builtLoc infixr 0 ==> + +-- | A type variable with a kind signature. +-- +-- > x :: A +-- > ===== +-- > kindedVar "x" (var "A") +kindedVar :: OccNameStr -> HsType' -> HsTyVarBndr' +kindedVar v t = noExt KindedTyVar (typeRdrName $ UnqualStr v) + (builtLoc t) diff --git a/src/GHC/SourceGen/Type/Internal.hs b/src/GHC/SourceGen/Type/Internal.hs --- a/src/GHC/SourceGen/Type/Internal.hs +++ b/src/GHC/SourceGen/Type/Internal.hs @@ -7,23 +7,21 @@ {-# LANGUAGE CPP #-} module GHC.SourceGen.Type.Internal where -import HsTypes +import GHC.Hs.Types as Types import SrcLoc (Located, unLoc) import GHC.SourceGen.Syntax.Internal -import GHC.SourceGen.Name.Internal -mkQTyVars :: [OccNameStr] -> LHsQTyVars' +mkQTyVars :: [HsTyVarBndr'] -> LHsQTyVars' mkQTyVars vars = withPlaceHolder $ noExt (withPlaceHolder HsQTvs) - $ map (builtLoc . noExt UserTyVar . typeRdrName . UnqualStr) - vars + $ map builtLoc vars sigType :: HsType' -> LHsSigType' sigType = implicitBndrs . builtLoc implicitBndrs :: t -> HsImplicitBndrs' t -implicitBndrs = withPlaceHolder . noExt (withPlaceHolder HsTypes.HsIB) +implicitBndrs = withPlaceHolder . noExt (withPlaceHolder Types.HsIB) -- TODO: GHC >= 8.6 provides parenthesizeHsType. For consistency with @@ -60,7 +58,7 @@ parTy = builtLoc . noExt HsParTy sigWcType :: HsType' -> LHsSigWcType' -sigWcType = noExt (withPlaceHolder HsTypes.HsWC) . sigType +sigWcType = noExt (withPlaceHolder Types.HsWC) . sigType wcType :: HsType' -> LHsWcType' -wcType = noExt (withPlaceHolder HsTypes.HsWC) . builtLoc +wcType = noExt (withPlaceHolder Types.HsWC) . builtLoc diff --git a/tests/pprint_examples.hs b/tests/pprint_examples.hs --- a/tests/pprint_examples.hs +++ b/tests/pprint_examples.hs @@ -116,26 +116,26 @@ , typeSig "g" $ op (var "A" @@ var "x") "*" (op (var "B" @@ var "y") "+" (var "C" @@ var "z")) - , class' [var "A" @@ var "a"] "B" ["b", "b'"] + , class' [var "A" @@ var "a"] "B" [bvar "b", bvar "b'"] [ typeSig "f" $ var "b" --> var "b'" , funBind "f" $ match [] $ var "id" ] - , class' [] "F" ["a", "b", "c"] + , class' [] "F" [bvar "a", bvar "b", bvar "c"] [ funDep ["a", "b"] ["c"] , funDep ["a"] ["b", "c"] ] - , class' [] "Ident" ["a", "b"] + , class' [] "Ident" [bvar "a", bvar "b"] [ funDep ["a"] ["b"] , funDep ["b"] ["a"] , typeSig "ident" $ var "a" --> var "b" ] - , type' "A" ["b", "c"] $ var "D" - , data' "A" ["b", "c"] + , type' "A" [bvar "b", bvar "c"] $ var "D" + , data' "A" [bvar "b", bvar "c"] [ prefixCon "A" [field (var "b"), field (var "c")] , prefixCon "D" [] ] [deriving' [var "X", var "Y"]] - , newtype' "A" ["b", "c"] (prefixCon "A" [field (var "b")]) + , newtype' "A" [bvar "b", bvar "c"] (prefixCon "A" [field (var "b")]) [deriving' [var "X", var "Y"]] , instance' (var "A" @@ var "b" @@ var "c") [ typeSig "f" $ var "b" --> var "c" @@ -145,7 +145,7 @@ in class' [var "Real" @@ a, var "Enum" @@ a] "Integral" - ["a"] + [bvar "a"] [ typeSig "divMod" $ a --> a --> tuple [a, a] , typeSig "div" $ a --> a --> a , funBind "div" @@ -159,7 +159,7 @@ , match [conP "False" []] $ string "False" ] ] - , data' "X" ["b"] + , data' "X" [bvar "b"] [ prefixCon "X" [ field $ var "A" @@ var "b" , strict $ field $ var "A" @@ var "b" diff --git a/tests/pprint_test.hs b/tests/pprint_test.hs --- a/tests/pprint_test.hs +++ b/tests/pprint_test.hs @@ -35,14 +35,21 @@ testPats :: DynFlags -> String -> [TestCase Pat'] -> TestTree testPats = testCases +testModule :: DynFlags -> String -> [TestCase HsModule'] -> TestTree +testModule = testCases main :: IO () main = runGhc (Just libdir) $ do dflags <- getDynFlags liftIO $ defaultMain $ testGroup "Tests" - [typesTest dflags, exprsTest dflags, declsTest dflags, patsTest dflags] + [ typesTest dflags + , exprsTest dflags + , declsTest dflags + , patsTest dflags + , modulesTest dflags + ] -typesTest, exprsTest, declsTest, patsTest :: DynFlags -> TestTree +typesTest, exprsTest, declsTest, patsTest, modulesTest :: DynFlags -> TestTree typesTest dflags = testGroup "Type" [ test "var" [ "A" :~ var "A" @@ -92,13 +99,20 @@ , "123" :~ numTy 123 ] , test "unit" - [ "()" :~ unit ] + [ "()" :~ unit + , "(# #)" :~ unboxedTuple [] + ] , test "list" [ "[x]" :~ listTy (var "x") , "'[]" :~ listPromotedTy [] , "'[x]" :~ listPromotedTy [var "x"] , "'[y, z]" :~ listPromotedTy [var "y", var "z"] ] + , test "tuple" + [ "(a, b)" :~ tuple [(var "a"), (var "b")] + , "(# a, b #)" :~ unboxedTuple [(var "a"), (var "b")] + , "'(a, b)" :~ tuplePromotedTy [(var "a"), (var "b")] + ] , test "tyPromotedVar" -- For some reason, older GHC pretty-printed an extra space. [ ifGhc88 "'Abc" " 'Abc" :~ tyPromotedVar "Abc" @@ -207,6 +221,22 @@ -- TODO: add more tests. [ "do (let x = 1 in x)" :~ do' [stmt $ let' [valBind "x" (int 1)] (var "x")] ] + , test "arithSeq" + [ "[a .. ]" :~ from (var "a") + , "[a, b .. ]" :~ fromThen (var "a") (var "b") + , "[a .. b]" :~ fromTo (var "a") (var "b") + , "[a, b .. c]" :~ fromThenTo (var "a") (var "b") (var "c") + ] + , test "list comprehension" + [ "[x | x <- [1 .. 10]]" :~ + listComp (bvar "x") [bvar "x" <-- fromTo (int 1) (int 10)] + , "[x + y | x <- [1 .. 10], y <- [11 .. 20], even y]" :~ + listComp (op (bvar "x") "+" (bvar "y")) + [ bvar "x" <-- fromTo (int 1) (int 10) + , bvar "y" <-- fromTo (int 11) (int 20) + , stmt $ var "even" @@ bvar "y" + ] + ] ] where test = testExprs dflags @@ -272,6 +302,28 @@ [ "pattern F a b = G b a" :~ patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"] ] + , test "dataDecl" + [ "data Either a b\n = Left a | Right b\n deriving Show" + :~ data' "Either" [bvar "a", bvar "b"] + [ prefixCon "Left" [field $ var "a"] + , prefixCon "Right" [field $ var "b"] + ] $ [deriving' [var "Show"]] + , "data Either a (b :: Type)\n = Left a | Right b\n deriving Show" + :~ data' "Either" [bvar "a", kindedVar "b" (var "Type")] + [ prefixCon "Left" [field $ var "a"] + , prefixCon "Right" [field $ var "b"] + ] $ [deriving' [var "Show"]] + ] + , test "newtypeDecl" + [ "newtype Const a b\n = Const a\n deriving Show" + :~ newtype' "Const" [bvar "a", bvar "b"] + (prefixCon "Const" [field $ var "a"]) + $ [deriving' [var "Show"]] + , "newtype Const a (b :: Type)\n = Const a\n deriving Show" + :~ newtype' "Const" [bvar "a", kindedVar "b" (var "Type")] + (prefixCon "Const" [field $ var "a"]) + [deriving' [var "Show"]] + ] ] where test = testDecls dflags @@ -324,3 +376,15 @@ where test = testPats dflags +-- TODO: Add more test cases from pprint_examples.hs. +modulesTest dflags = testGroup "Modules" + [ test "import" + [ "import M" :~ + module' Nothing Nothing [import' "M"] [] + , "import {-# SOURCE #-} M" :~ + module' Nothing Nothing + [source $ import' "M"] [] + ] + ] + where + test = testModule dflags