diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for haskell-syntax +# 0.4.1.0 +- Add `funBindsWithFixity`. +- Add `standaloneDeriving`. + # 0.4.0.0 ## Breaking Changes 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,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 5ce0ceef64535fb124b604d3193e37b6dc89ea437af2ac6cbe6c631afad662ed name: ghc-source-gen -version: 0.4.0.0 +version: 0.4.1.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 @@ -57,7 +55,10 @@ GHC.SourceGen.Type.Internal hs-source-dirs: src - default-extensions: DataKinds FlexibleInstances TypeSynonymInstances + default-extensions: + DataKinds + FlexibleInstances + TypeSynonymInstances build-depends: base >=4.7 && <5 , ghc >=8.4 && <8.11 @@ -84,13 +85,16 @@ Paths_ghc_source_gen hs-source-dirs: tests - default-extensions: DataKinds FlexibleInstances TypeSynonymInstances + default-extensions: + DataKinds + FlexibleInstances + TypeSynonymInstances build-depends: - QuickCheck >=2.10 && <2.14 + QuickCheck >=2.10 && <2.15 , base >=4.7 && <5 , ghc >=8.4 && <8.11 , ghc-source-gen - , tasty >=1.0 && <1.3 + , tasty >=1.0 && <1.4 , tasty-hunit ==0.10.* , tasty-quickcheck >=0.9 && <0.11 default-language: Haskell2010 @@ -103,13 +107,16 @@ Paths_ghc_source_gen hs-source-dirs: tests - default-extensions: DataKinds FlexibleInstances TypeSynonymInstances + default-extensions: + DataKinds + FlexibleInstances + TypeSynonymInstances build-depends: base >=4.7 && <5 , ghc >=8.4 && <8.11 , ghc-paths ==0.1.* , ghc-source-gen - , tasty >=1.0 && <1.3 + , tasty >=1.0 && <1.4 , tasty-hunit ==0.10.* default-language: Haskell2010 @@ -121,12 +128,15 @@ Paths_ghc_source_gen hs-source-dirs: tests - default-extensions: DataKinds FlexibleInstances TypeSynonymInstances + default-extensions: + DataKinds + FlexibleInstances + TypeSynonymInstances build-depends: base >=4.7 && <5 , ghc >=8.4 && <8.11 , ghc-paths ==0.1.* , ghc-source-gen - , tasty >=1.0 && <1.3 + , tasty >=1.0 && <1.4 , tasty-hunit ==0.10.* default-language: Haskell2010 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 @@ -15,6 +15,7 @@ -- * Functions , funBind , funBinds + , funBindsWithFixity -- * Values , valBind , valBindGRHSs @@ -45,9 +46,12 @@ ) where import BasicTypes (LexicalFixity(..)) +import Data.Bool (bool) +import Data.Maybe (fromMaybe) import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.Types +import GhcPlugins (isSymOcc) import TcEvidence (HsWrapper(WpHole)) import GHC.SourceGen.Binds.Internal @@ -74,6 +78,31 @@ typeSig :: HasValBind t => OccNameStr -> HsType' -> t typeSig n = typeSigs [n] +-- | Defines a function or value, with an explicit fixity. When given +-- 'Nothing', use infix notation iff the given name is symbolic. +-- +-- > id x = x +-- > ===== +-- > funBindsWithFixity (Just Prefix) "id" [match [var "x"] (var "x")] +-- +-- > True && True = True +-- > True && False = False +-- > ===== +-- > funBindsWithFixity Nothing "not" +-- > [ match [conP "True" []] (var "False") +-- > , match [conP "False" []] (var "True") +-- > ] +funBindsWithFixity :: HasValBind t => Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t +funBindsWithFixity fixity name matches = bindB $ withPlaceHolder + (noExt FunBind name' + (matchGroup context matches) WpHole) + [] + where + name' = valueRdrName $ unqual name + occ = valueOccName name + fixity' = fromMaybe (bool Prefix Infix $ isSymOcc occ) fixity + context = FunRhs name' fixity' NoSrcStrict + -- | Defines a function or value. -- -- > f = x @@ -92,13 +121,7 @@ -- > , match [conP "False" []] (var "True") -- > ] funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t -funBinds name matches = bindB $ withPlaceHolder - (noExt FunBind name' - (matchGroup context matches) WpHole) - [] - where - name' = valueRdrName $ unqual name - context = FunRhs name' Prefix NoSrcStrict +funBinds = funBindsWithFixity (Just Prefix) -- | Defines a function that has a single case. -- 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 @@ -30,6 +30,10 @@ #if MIN_VERSION_ghc(8,6,0) , derivingVia #endif + , standaloneDeriving + , standaloneDerivingStock + , standaloneDerivingNewtype + , standaloneDerivingAnyclass -- * Class declarations , class' , ClassDecl @@ -56,8 +60,12 @@ ( ConDeclField(..) , FieldOcc(..) , HsConDetails(..) + , HsImplicitBndrs (..) , HsSrcBang(..) , HsType(..) +#if MIN_VERSION_ghc(8,6,0) + , HsWildCardBndrs (..) +#endif #if MIN_VERSION_ghc(8,8,0) , HsArg(..) #endif @@ -409,6 +417,31 @@ -- Available with @ghc>=8.6@. derivingVia :: HsType' -> [HsType'] -> HsDerivingClause' derivingVia t = derivingWay (Just $ ViaStrategy $ sigType t) +#endif + +standaloneDeriving :: HsType' -> HsDecl' +standaloneDeriving = standaloneDerivingWay Nothing + +standaloneDerivingStock :: HsType' -> HsDecl' +standaloneDerivingStock = standaloneDerivingWay (Just StockStrategy) + +standaloneDerivingNewtype :: HsType' -> HsDecl' +standaloneDerivingNewtype = standaloneDerivingWay (Just NewtypeStrategy) + +standaloneDerivingAnyclass :: HsType' -> HsDecl' +standaloneDerivingAnyclass = standaloneDerivingWay (Just AnyclassStrategy) + +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) + hsWC = +#if MIN_VERSION_ghc(8,6,0) + noExt HsWC +#else + id #endif -- | Declares multiple pattern signatures of the same type. diff --git a/tests/pprint_test.hs b/tests/pprint_test.hs --- a/tests/pprint_test.hs +++ b/tests/pprint_test.hs @@ -279,6 +279,11 @@ [ match [bvar "True"] (var "False") , match [bvar "False"] (var "True") ] + , "True && True = True\nTrue && False = False" :~ + funBindsWithFixity Nothing "&&" + [ match [bvar "True", bvar "True"] (var "True") + , match [bvar "True", bvar "False"] (var "False") + ] , "not x\n | x = False\n | otherwise = True" :~ funBind "not" $ matchGRHSs [bvar "x"] $ guardedRhs @@ -323,6 +328,18 @@ :~ newtype' "Const" [bvar "a", kindedVar "b" (var "Type")] (prefixCon "Const" [field $ var "a"]) [deriving' [var "Show"]] + ] + , test "standaloneDeriving" + [ "deriving instance Show Int" + :~ standaloneDeriving (var "Show" @@ var "Int") + , "deriving instance Show a => Show (Maybe a)" + :~ standaloneDeriving ([var "Show" @@ var "a"] ==> var "Show" @@ (var "Maybe" @@ var "a")) + , "deriving stock instance Show Int" + :~ standaloneDerivingStock (var "Show" @@ var "Int") + , "deriving newtype instance Show a => Show (Identity a)" + :~ standaloneDerivingNewtype ([var "Show" @@ var "a"] ==> var "Show" @@ (var "Identity" @@ var "a")) + , "deriving anyclass instance Show Person" + :~ standaloneDerivingAnyclass (var "Show" @@ var "Person") ] ] where