derive-topdown 0.0.3.0 → 0.1.0.0

raw patch · 22 files changed

+2661/−1006 lines, 22 filesdep +HUnitdep +binarydep +containersdep ~basedep ~mtldep ~primitivesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, binary, containers, derive-topdown, haskell-src, th-abstraction

Dependency ranges changed: base, mtl, primitive, syb, template-haskell, th-expand-syns, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +54/−0
• ChangeLog.md +0/−46
• LICENSE +28/−20
• README.md +130/−119
• Setup.hs +2/−2
• derive-topdown.cabal +91/−46
• src/Data/Derive/Superclass.hs +95/−161
• src/Data/Derive/TopDown.hs +70/−94
• src/Data/Derive/TopDown/CxtGen.hs +328/−0
• src/Data/Derive/TopDown/Instance.hs +105/−57
• src/Data/Derive/TopDown/IsInstance.hs +68/−0
• src/Data/Derive/TopDown/Lib.hs +334/−279
• src/Data/Derive/TopDown/Standalone.hs +166/−137
• src/Data/Derive/TopDown/TH.hs +80/−45
• test/Arity.hs +25/−0
• test/Derive.hs +189/−0
• test/Generic.hs +211/−0
• test/Instance.hs +99/−0
• test/Spec.hs +121/−0
• test/Template.hs +164/−0
• test/Types.hs +288/−0
• test/Utils.hs +13/−0

@@ -0,0 +1,54 @@+derive-topdown+======+derive-topdown-0.1.0.0+--------------+- `0.1.0.0`+    * Almost a reimplementation the deriving and instance generation functions.+	* Implement class context generation. Now only necessary context type will be generated. +    * This version only compatible for ghc-8.6 to ghc-9.10. ghc-8.4 and ghc-8.2 can build but not able to run test cases.+++derive-topdown-0.0.3.0+--------------+- `0.0.3.0`+	* Adapt to GHC 9.0.++derive-topdown-0.0.2.1+--------------+- `0.0.2.1`+	* Remove unnecessary dependencies for testing.++derive-topdown-0.0.2.0+--------------+- `0.0.2.0`+	* Add deriving superclass functions. When you want to derive a class instance, not necessary to derive all its superclasses.++derive-topdown-0.0.1.0+--------------+- `0.0.1.0`+    * Imporve error message.Will print the types list when type is not data or newtype defined.++derive-topdown-0.0.0.9+--------------+- `0.0.0.9` +    * Changed API for `strategy_derivng(s)`. Deriving strategy should be specified first as the default grammar of `deriving`.+    * Provided `deriving_with_breaks` function so that one can specify the types that prevent further standalone deriving declarations from generating process. This is mainly for `Generic` class. See the test of deriving `Generic` for `HsModule`.+    * Fixed Strategy deriving problem. Deriving with NewtypeStrategy on data type defined by `data` keyword will be ignored.+    * Fixed problem with class context generation for phantom types. Phantom types will not be in the context now.+    * Fixed `ArrowT` problem. It should be not a type variable and should appear in the context.+    * Handled data constructor which contains explicit `forall`.+    * Added test. It generates class instances for data types in `template-haskell` and `haskell-src`.++derive-topdown-0.0.0.7+--------------+- `0.0.0.7` is a more carefully implemented version of derive-topdown.+All APIs are **totally** changed compared with 0.0.0.2. Originally it did not work with types that contain type synonyms and polymorphic types. It can work for most common cases in this version now.++derive-topdown-0.0.0.2+--------------+- Fixed some cabal file and API problems.++derive-topdown-0.0.0.1+--------------+- This is only an experimental implementation for deriving class instances from top to bottom.+There is a lot of deficiencies.

@@ -1,46 +0,0 @@-derive-topdown
-======
-derive-topdown-0.0.3.0
---------------
-- `0.0.3.0`
-	* Adapt to GHC 9.0.
-
-derive-topdown-0.0.2.1
---------------
-- `0.0.2.1`
-	* Remove unnecessary dependencies for testing.
-
-derive-topdown-0.0.2.0
---------------
-- `0.0.2.0`
-	* Add deriving superclass functions. When you want to derive a class instance, not necessary to derive all its superclasses.
-
-derive-topdown-0.0.1.0
---------------
-- `0.0.1.0`
-    * Imporve error message.Will print the types list when type is not data or newtype defined.
-
-derive-topdown-0.0.0.9
---------------
-- `0.0.0.9` 
-    * Changed API for `strategy_derivng(s)`. Deriving strategy should be specified first as the default grammar of `deriving`.
-    * Provided `deriving_with_breaks` function so that one can specify the types that prevent further standalone deriving declarations from generating process. This is mainly for `Generic` class. See the test of deriving `Generic` for `HsModule`.
-    * Fixed Strategy deriving problem. Deriving with NewtypeStrategy on data type defined by `data` keyword will be ignored.
-    * Fixed problem with class context generation for phantom types. Phantom types will not be in the context now.
-    * Fixed `ArrowT` problem. It should be not a type variable and should appear in the context.
-    * Handled data constructor which contains explicit `forall`.
-    * Added test. It generates class instances for data types in `template-haskell` and `haskell-src`.
-
-derive-topdown-0.0.0.7
---------------
-- `0.0.0.7` is a more carefully implemented version of derive-topdown.
-All APIs are **totally** changed compared with 0.0.0.2. Originally it did not work with types that contain type synonyms and polymorphic types. It can work for most common cases in this version now.
-
-derive-topdown-0.0.0.2
---------------
-- Fixed some cabal file and API problems.
-
-derive-topdown-0.0.0.1
---------------
-- This is only an experimental implementation for deriving class instances from top to bottom.
-There is a lot of deficiencies.

@@ -1,20 +1,28 @@-Copyright (c) 2015 songzh
-
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be included
-in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+BSD 3-Clause License++Copyright (c) 2024, Song Zhang++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,120 +1,131 @@-# derive-topdown
-[![Hackage version](https://img.shields.io/hackage/v/derive-topdown.svg?label=Hackage)](https://hackage.haskell.org/package/derive-topdown) [![Stackage version](https://www.stackage.org/package/derive-topdown/badge/lts?label=Stackage)](https://www.stackage.org/package/derive-topdown)
-
-This is a Haskell project which will derive type class instances from top for a composite data type
-
-
-### 1. Standalone deriving
-There are functions named `deriving_`, `derivings`, `derivingss`. Please see the API for their types.
-
-	{-# LANGUAGE StandaloneDeriving,
-		ConstraintKinds,
-		UndecidableInstances,
-		GADTs,
-		TemplateHaskell,
-		DeriveGeneric #-}
-	{-# OPTIONS_GHC -ddump-splices #-}
-	
-	import Data.Derive.TopDown
-	import GHC.Generics
-	import Data.Binary
-	imoprt Data.Aeson
-	import Data.Aeson.TH
-
-	data Gender = Male | Female
-	type Age = Int
-	data Person a = P {name :: String , age :: Int, gender :: Gender}
-	data Department a = D {dname :: String , 
-						   head :: Person a, 
-						   staff :: [Person a]}
-	data Company a = C {cname :: String, 
-	                    departments :: [Department a]}
-	
-	derivings [''Eq, ''Ord, ''Generic] ''Company
-
-You will get:
-
-		derivings [''Eq, ''Ord, ''Generic] ''Company
-	  ======>
-	    deriving instance Eq Gender
-	    deriving instance Eq (Person a_acKV)
-	    deriving instance Eq a_acKU => Eq (Department a_acKU)
-	    deriving instance Eq a_acKT => Eq (Company a_acKT)
-	    deriving instance Ord Gender
-	    deriving instance Ord (Person a_acKV)
-	    deriving instance Ord a_acKU => Ord (Department a_acKU)
-	    deriving instance Ord a_acKT => Ord (Company a_acKT)
-	    deriving instance Generic Gender
-	    deriving instance Generic (Person a_acKV)
-	    deriving instance Generic (Department a_acKU)
-	    deriving instance Generic (Company a_acKT)
-
-### 2. Empty Instances generation
-
-For empty class instances deriving, `instance_`, `instances`, `instancess` are provided. We can use it in this way.
-
-	    instances [''Binary] ''Company
-	  ======>
-	    instance Binary Gender
-	    instance Binary (Person a_af50)
-	    instance Binary a_af4Z => Binary (Department a_af4Z)
-	    instance Binary a_af4Y => Binary (Company a_af4Y)
-
-### 3. Usage with Template Haskell
-For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used:
-	
-	   derivingTHs
-	      [(''ToJSON, deriveToJSON defaultOptions),
-	       (''FromJSON, deriveFromJSON defaultOptions)]
-	      ''Company
-	  ======>
-	    instance ToJSON Gender where
-	      toJSON
-	        = \ value_amQG
-	            -> case value_amQG of {
-	                 Male -> String (text-1.2.2.2:Data.Text.pack "Male")
-	                 Female -> String (text-1.2.2.2:Data.Text.pack "Female") }
-	      toEncoding
-	        = \ value_amQH
-	            -> case value_amQH of {
-	                 Male
-	                   -> Data.Aeson.Encoding.Internal.text
-	                        (text-1.2.2.2:Data.Text.pack "Male")
-	                 Female
-	                   -> Data.Aeson.Encoding.Internal.text
-	                        (text-1.2.2.2:Data.Text.pack "Female") }
-	    instance ToJSON a_amqg => ToJSON (Person a_amqg) where
-	      toJSON
-	        = \ value_amQy
-	        ...
-	        ...
-You can use this this function with [`derive`](http://hackage.haskell.org/package/derive) package. However, it seems that this package is broken with GHC >= 802.
-
-### 4. Deriving the superclasses
-`Data.Derive.Superclass` provides `deriving_superclasses`, `strategy_deriving_superclasses` and newtype_deriving_superclasses, gnds can be used to derive class instance and its superclass instances. 
-
-For example:
-
-	    data A = A
-	    deriving_superclasses ''Ord ''A
-
-You wil get:
-
-	    deriving_superclasses ''Ord ''A
-	  ======>
-	    deriving instance Ord A
-	    deriving instance Eq A
-
-
-### 5. Deriving with strategies in GHC 8.2
-If you want to specify the strategy for deriving mechanism then `strategy_deriving`, `strategy_derivings` and `strategy_derivingss` can be used.
-The 3 strategies for deriving `StockStrategy`,`AnyclassStrategy`,`NewtypeStrategy` are exposed when you import `TopDown`. They can be written as `stock`, `anyclass` as the default grammar. For `newtype`, you can write it as `newtype_` since there is a clison with `newtype` for data declaration. Please see [DerivingStrategies](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies)
-
-
-#### **NOTE**:  About deriving instances of Typeable
-There is a bug with `isInstance` function when working with Typeable class. See [`ticket #11251`](https://ghc.haskell.org/trac/ghc/ticket/11251). So there might be problems if you really want to derive `Typeable` class. However, this bug should not affect you too much here since GHC now has `AutoDeriveTypeable` extension, which means you should never derive `Typeable` manually.
-
-#### **NOTE**: You cannot derive a type synonym.
-`derive-topdown` will not work with `-XTypeSynonymInstances` language extension. The top node in the data declaration tree has to be a data or newtype.
-
+# derive-topdown+[![Hackage version](https://img.shields.io/hackage/v/derive-topdown.svg?label=Hackage)](https://hackage.haskell.org/package/derive-topdown) [![Stackage version](https://www.stackage.org/package/derive-topdown/badge/lts?label=Stackage)](https://www.stackage.org/package/derive-topdown)++This is a Haskell project which will derive type class instances from top for a composite data type.++## 1. Standalone deriving+There are functions named `deriving_`, `derivings`, `derivingss`. Please see the API for their types.++``` haskell+{-# LANGUAGE StandaloneDeriving,+    ConstraintKinds,+    UndecidableInstances,+    GADTs,+    TemplateHaskell,+    DeriveGeneric #-}+{-# OPTIONS_GHC -ddump-splices #-}++import Data.Derive.TopDown+import GHC.Generics+import Data.Binary+import Data.Aeson+import Data.Aeson.TH++data Gender = Male | Female+type Age = Int+data Person a = P {name :: String , age :: Int, gender :: Gender}+data Department a = D {dname :: String , +                        head :: Person a, +                        staff :: [Person a]}+data Company a = C {cname :: String, +                    departments :: [Department a]}++derivings [''Eq, ''Ord, ''Generic] ''Company+```+You will get:+```haskell+derivings [''Eq, ''Ord, ''Generic] ''Company+======>+deriving instance Eq Gender+deriving instance Eq (Person a_acKV)+deriving instance Eq a_acKU => Eq (Department a_acKU)+deriving instance Eq a_acKT => Eq (Company a_acKT)+deriving instance Ord Gender+deriving instance Ord (Person a_acKV)+deriving instance Ord a_acKU => Ord (Department a_acKU)+deriving instance Ord a_acKT => Ord (Company a_acKT)+deriving instance Generic Gender+deriving instance Generic (Person a_acKV)+deriving instance Generic (Department a_acKU)+deriving instance Generic (Company a_acKT)+```+## 2. Empty Instances generation++For empty class instances deriving, `instance_`, `instances`, `instancess` are provided. We can use it in this way.++```haskell+instances [''Binary] ''Company+======>+instance Binary Gender+instance Binary (Person a_af50)+instance Binary a_af4Z => Binary (Department a_af4Z)+instance Binary a_af4Y => Binary (Company a_af4Y)+```+## 3. Usage with Template Haskell+For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used:+```haskell+derivingTHs+    [(''ToJSON, deriveToJSON defaultOptions),+    (''FromJSON, deriveFromJSON defaultOptions)]+    ''Company+======>+instance ToJSON Gender where+    toJSON+    = \ value_amQG+        -> case value_amQG of {+                Male -> String (text-1.2.2.2:Data.Text.pack "Male")+                Female -> String (text-1.2.2.2:Data.Text.pack "Female") }+    toEncoding+    = \ value_amQH+        -> case value_amQH of {+                Male+                -> Data.Aeson.Encoding.Internal.text+                    (text-1.2.2.2:Data.Text.pack "Male")+                Female+                -> Data.Aeson.Encoding.Internal.text+                    (text-1.2.2.2:Data.Text.pack "Female") }+instance ToJSON a_amqg => ToJSON (Person a_amqg) where+    toJSON+    = \ value_amQy+    ...+    ...+```+You can use this this function with [`derive`](http://hackage.haskell.org/package/derive) package. However, it seems that this package is broken with GHC >= 802.++## 4. Deriving the superclasses+`Data.Derive.Superclass` provides `deriving_superclasses`, `strategy_deriving_superclasses` and newtype_deriving_superclasses, gnds can be used to derive class instance and its superclass instances. ++For example:+```haskell+data A = A+deriving_superclasses ''Ord ''A+```+You wil get:+```haskell+deriving_superclasses ''Ord ''A+======>+deriving instance Ord A+deriving instance Eq A+```++Mutual recursive type decalrations need to derive superclass together as the following:+```haskell+fmap concat (sequence [(deriving_superclasses ''Ord ''T2), (deriving_superclasses ''Ord ''T3)])+```+In the code above, T2 and T3 are mutual recursive data types.++## 5. Deriving with strategies in GHC 8.2+If you want to specify the strategy for deriving mechanism then `strategy_deriving`, `strategy_derivings` and `strategy_derivingss` can be used.+The 3 strategies for deriving `StockStrategy`,`AnyclassStrategy`,`NewtypeStrategy` are exposed when you import `TopDown`. They can be written as `stock`, `anyclass` as the default grammar. For `newtype`, you can write it as `newtype_` since there is a clison with `newtype` for data declaration. Please see [DerivingStrategies](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies)++## Note+### Derive with breaks+The deriving process might be interrupted by a given list of type names. The generation process will stop on those give names. Please see the test case.++### **NOTE**:  About deriving instances of Typeable+There is a bug with `isInstance` function when working with Typeable class. See [`ticket #11251`](https://ghc.haskell.org/trac/ghc/ticket/11251). So there might be problems if you really want to derive `Typeable` class. However, this bug should not affect you too much here since GHC now has `AutoDeriveTypeable` extension, which means you should never derive `Typeable` manually.++### **NOTE**: You cannot derive a type synonym.+`derive-topdown` will not work with `-XTypeSynonymInstances` language extension. The top node in the data declaration tree has to be a data or newtype.+ More discussion about `derive-topdown`, please see [`ticket #10607`](https://ghc.haskell.org/trac/ghc/ticket/10607)

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import           Distribution.Simple+main = defaultMain

@@ -1,46 +1,91 @@--- Initial derive-topdown.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
-name:                derive-topdown
-version:             0.0.3.0
-synopsis:            Help Haskellers derive class instances for composited data types.
-description:         This package will make it easier to derive class instance for complex composited data types by using Template Haskell.
-license:             BSD3
-license-file:        LICENSE
-author:              songzh <Haskell.Zhang.Song@hotmail.com>
-maintainer:          songzh <Haskell.Zhang.Song@hotmail.com>
-homepage:            https://github.com/HaskellZhangSong/derive-topdown                   
-copyright:           (C) songzh
-category:            Development
-build-type:          Simple
-extra-source-files:  README.md, ChangeLog.md
-cabal-version:       >=1.10
-tested-with:         GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1                  
-source-repository head
-  type: git
-  location: git://github.com/HaskellZhangSong/derive-topdown.git
-                     
-library
-  exposed-modules:    Data.Derive.TopDown,
-                      Data.Derive.Superclass
-  other-modules:      Data.Derive.TopDown.Lib,
-                      Data.Derive.TopDown.Standalone,
-                      Data.Derive.TopDown.Instance
-                      Data.Derive.TopDown.TH
-  -- other-extensions:    
-  build-depends:       base >=4.8 && <5.0,
-                       -- considered 7.10, 8.0, 8.2
-                       template-haskell>=2.10,
-                       -- compatible from 7.0 to 7.11
-                       syb>=0.4,
-                       -- compatible from 7.4 to 8.0
-                       primitive>=0.6.2,
-                       -- fully compatible
-                       th-expand-syns>=0.4.3,
-                       -- compatible from 7.6 to 8.2
-                       mtl>=2.1.0,
-                       --
-                       transformers>=0.4.2
-  hs-source-dirs:      src
-  default-language:    Haskell2010
-  default-extensions:  TemplateHaskell,CPP+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           derive-topdown+version:        0.1.0.0+synopsis:       Derive type class instances+description:    This package will make it easier to derive class instance for complex composited data types by using Template Haskell.+category:       Development+homepage:       https://github.com/HaskellZhangSong/derive-topdown#readme+bug-reports:    https://github.com/HaskellZhangSong/derive-topdown/issues+author:         Song Zhang+maintainer:     Song Zhang <Haskell.Zhang.Song@hotmail.com>+copyright:      (c) 2024 Song Zhang+license:        BSD3+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/HaskellZhangSong/derive-topdown++library+  exposed-modules:+      Data.Derive.Superclass+      Data.Derive.TopDown.IsInstance+      Data.Derive.TopDown.Instance+      Data.Derive.TopDown.CxtGen+      Data.Derive.TopDown.Standalone+      Data.Derive.TopDown.TH+      Data.Derive.TopDown+  other-modules:+      Data.Derive.TopDown.Lib+  hs-source-dirs:+      src+  default-extensions:+      TemplateHaskell , StandaloneDeriving , CPP+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.8 && <5+    , containers+    , mtl+    , primitive+    , syb+    , template-haskell+    , th-abstraction+    , th-expand-syns+    , transformers+  default-language: Haskell2010++test-suite derive-topdown-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Arity+      Derive+      Generic+      Instance+      Template+      Types+      Utils+      Paths_derive_topdown+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      HUnit+    , base >=4.8 && <5+    , binary+    , containers+    , derive-topdown+    , haskell-src+    , mtl+    , primitive+    , syb+    , template-haskell+    , th-abstraction+    , th-expand-syns+    , transformers+  default-language: Haskell2010+  if impl(ghc >= 8.6.1)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-missing-signatures -Wno-unticked-promoted-constructors -Wno-orphans -Wno-missing-export-lists -Wno-star-is-type+  else+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-missing-signatures -Wno-unticked-promoted-constructors -Wno-orphans -Wno-missing-export-lists

@@ -1,161 +1,95 @@-{-|
-
-Module      : Data.Derive.TopDown
-Description : Help Haskellers derive class instances for composited data types.
-Copyright   : (c) songzh
-License     : BSD3
-Maintainer  : Haskell.Zhang.Song@hotmail.com
-Stability   : experimental
-
-Class dependencies can be complex sometimes, such as numeric and monadic classes. Making instances of them can be very tedious. Functoins in this module will help you derive the specified class instance with all the superclass instances of it.  For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@, @DeriveAnyClass@
-
-You may also need to enable GHC options @-ddump-splices@. 
-
-For example:
-
-> data A = A
-> deriving_superclasses ''Ord ''A
-
-You wil get:
-
->    deriving_superclasses ''Ord ''A
->  ======>
->    deriving instance Ord A
->    deriving instance Eq A
-
-'Eq' is automatically derived when 'Ord' is derived, since 'Eq' is a superclass of 'Ord'
-
-> newtype IO_ a = IO_ (IO a)
-> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_ 
-
-You will get:
-
->    strategy_deriving_superclasses newtype_ ''MonadIO ''IO_
->  ======>
->    deriving newtype instance MonadIO IO_
->    deriving newtype instance Monad IO_
->    deriving newtype instance Applicative IO_
->    deriving newtype instance Functor IO_
-
-Appearently, @Functor f => Applicative f => Monad f => MonadIO f@
-
-> newtype F32 = F32 Float
-> newtype_deriving_superclasses ''RealFloat ''F32
-
-You will get:
-
->    newtype_deriving_superclasses ''RealFloat ''F32
->  ======>
->    deriving newtype instance RealFloat F32
->    deriving newtype instance RealFrac F32
->    deriving newtype instance Real F32
->    deriving newtype instance Num F32
->    deriving newtype instance Ord F32
->    deriving newtype instance Eq F32
->    deriving newtype instance Fractional F32
->    deriving newtype instance Floating F32
-
-Some of these examples are from [#13368](https://ghc.haskell.org/trac/ghc/ticket/13368).
--}
-
-module Data.Derive.Superclass 
-       (deriving_superclasses,
-#if __GLASGOW_HASKELL__ >= 802        
-        strategy_deriving_superclasses,
-        newtype_deriving_superclasses,
-        gnds
-#endif
-        )where
-
-import Data.Derive.TopDown.Lib
-import Language.Haskell.TH
-import Language.Haskell.TH.Lib
-import Debug.Trace
-import Control.Monad
-import Data.List
-import Control.Monad.Trans.State
-import Control.Monad.Trans
-import Data.Maybe
-import Language.Haskell.TH.Ppr
-
-isHigherOrderClass :: Name -> Q Bool
-isHigherOrderClass ty = do
-                    cla <- reify ty
-                    case cla of
-                        ClassI (ClassD _ _ vars _ _) _ -> do
-#if __GLASGOW_HASKELL__ > 810
-                                                    let (KindedTV _ _ k) = head vars
-#else 
-                                                    let (KindedTV _ k) = head vars
-#endif
-                                                    if k == StarT
-                                                        then return True
-                                                        else return False
-                        _ -> error $ show ty ++ " is not a class"
-                    
-
-
-deriving_superclasses :: Name -> Name -> Q [Dec]
-deriving_superclasses cn tn = do
-                            a <- evalStateT (deriving_superclasses' 
-#if __GLASGOW_HASKELL__ >= 802
-                                             Nothing 
-#endif                            
-                                             cn tn) []
-                            return a
-
-#if __GLASGOW_HASKELL__ >= 802
-strategy_deriving_superclasses :: DerivStrategy -> Name -> Name -> Q [Dec]
-strategy_deriving_superclasses st cn tn = do
-                            a <- evalStateT (deriving_superclasses' (Just st) cn tn) []
-                            return a
-
--- |Use newtype strategy to derive all the superclass instances.
-newtype_deriving_superclasses = strategy_deriving_superclasses NewtypeStrategy
-
--- |Abbreviation for @newtype_deriving_superclasses@.
-gnds = newtype_deriving_superclasses
-#endif
-
-#if __GLASGOW_HASKELL__ >= 802
-deriving_superclasses' :: Maybe DerivStrategy -> Name -> Name -> StateT [Type] Q [Dec]
-deriving_superclasses' st cn tn = do
-#else
-deriving_superclasses' :: Name -> Name -> StateT [Type] Q [Dec]
-deriving_superclasses' cn tn = do
-#endif
-                    (tvbs,cons) <- getTyVarCons cn tn
-                    let tp = AppT (ConT cn) (ConT tn) 
-                    types <- get
-                    isCnHighOrderClass <- lift $ isHigherOrderClass cn
-                    classContext <- if isCnHighOrderClass
-                                        then lift $ generateClassContext cn tn
-                                        else return Nothing
-                    --
-                    let Just a = classContext
-                    let typeNames = map getTVBName tvbs
-                    isIns <- lift $ isInstance' cn [ConT tn]
-                    let context = maybeToList classContext
-                    if (isIns || elem tp types)
-                        then return []
-                        else
-                            do
-                            topClassInstance <- return [StandaloneDerivD 
-#if __GLASGOW_HASKELL__ >= 802
-                                                            st
-#endif
-                                                            context tp]
-
-                            modify (tp:)
-                            ci <- lift $ reify cn
-                            case ci of
-                                ClassI (ClassD ctx _ _ _ _) _ -> do
-                                                    let classConTs = map getTypeConstructor ctx
-                                                    ss <- fmap (nub.concat) $ forM classConTs $ \(ConT className) -> do
-                                                                                    superclass_decls <- deriving_superclasses' 
-#if __GLASGOW_HASKELL__ >= 802
-                                                                                                            st
-#endif
-                                                                                                            className tn
-                                                                                    return superclass_decls
-                                                    return $ topClassInstance ++ ss+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.Superclass+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.Superclass+  ( deriving_superclasses+  , strategy_deriving_superclasses+  , newtype_deriving_superclasses+  , gnds+  ) where++import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.State+import           Data.Derive.TopDown.CxtGen+import           Data.Derive.TopDown.IsInstance+import           Data.Derive.TopDown.Lib+import           Data.List                      ( foldl1'+                                                , nub+                                                )+import           Language.Haskell.TH++-- Only support class that has paramter with kind * or * -> *+deriving_superclasses'+  :: Maybe DerivStrategy -> ClassName -> TypeName -> StateT [Type] Q [Dec]+deriving_superclasses' st cn tn = do+  pnames             <- lift $ reifyTypeParameters tn+  types              <- get+  isCnHighOrderClass <- lift $ isHigherOrderClass cn+  let t = if isCnHighOrderClass+        then+          let pns = init pnames+          in  if null pns+                then ConT tn+                else foldl1' AppT (ConT tn : (map VarT pns))+        else foldl1' AppT (ConT tn : (map VarT pnames))+  let tp = AppT (ConT cn) t++  isIns <- lift $ isInstance' cn [t]+  if (isIns || elem tp types)+    then return []+    else do+      classContext <- if isCnHighOrderClass+        then return []+        else lift $ genInferredContext cn tn+      let topClassInstance = [StandaloneDerivD st classContext tp]+      modify (tp :)+      ci <- lift $ reify cn+      case ci of+        ClassI (ClassD ctx _ _ _ _) _ -> do+          let classConTs = map getTypeConstructor ctx+          ss <- fmap (nub . concat) $ forM classConTs $ \superCln ->+            case superCln of+              ConT className -> do+                superclass_decls <- deriving_superclasses' st className tn+                return superclass_decls+              x -> error $ "cannot generate class for " ++ show x+          return $ topClassInstance ++ ss+        _ -> error $ show cn ++ "is not type class"++{- | Note: It cannot be used with mutual recursive types.++For mutual recursive types, you need to put them together. For mutual recursive types @T1@ and @T2@:++@+fmap concat (sequence [(deriving_superclasses ''Ord ''T1), (deriving_superclasses ''Ord ''T2)])+@+-}+deriving_superclasses :: ClassName -> TypeName -> Q [Dec]+deriving_superclasses cn tn =+  evalStateT (deriving_superclasses' Nothing cn tn) []++strategy_deriving_superclasses+  :: DerivStrategy  -- ^ deriving strategy+  -> ClassName      -- ^ class name+  -> TypeName       -- ^ type name+  -> Q [Dec]+strategy_deriving_superclasses st cn tn =+  evalStateT (deriving_superclasses' (Just st) cn tn) []++-- | Use newtype strategy to derive all the superclass instances.+newtype_deriving_superclasses :: ClassName -> TypeName -> Q [Dec]+newtype_deriving_superclasses = strategy_deriving_superclasses NewtypeStrategy++-- | Abbreviation for @newtype_deriving_superclasses@. for generalized newtype deriving+gnds :: ClassName -> TypeName -> Q [Dec]+gnds = newtype_deriving_superclasses

@@ -1,94 +1,70 @@-{-|
-
-Module      : Data.Derive.TopDown
-Description : Help Haskellers derive class instances for composited data types.
-Copyright   : (c) songzh
-License     : BSD3
-Maintainer  : Haskell.Zhang.Song@hotmail.com
-Stability   : experimental
-
-
-@derive-topdown@ will make it easier to derive class instance for complex composited data types by using Template Haskell. For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@,@ DeriveAnyClass@.
-
-You may also need to enable GHC options @-ddump-splices@. 
-
-For example:
-
-> data Gender = Male | Female
-> type Age = Int
-> data Person a = P {name :: String , age :: Int, gender :: Gender}
-> data Department a = D {dname :: String , head :: Person a, staff :: [Person a]}
-> data Company a = C {cname :: String, departments :: [Department a]}
-
-> derivings [''Eq, ''Ord, ''Generic] ''Company
-
-You will get:
-
->     derivings [''Eq, ''Ord, ''Generic] ''Company
->   ======>
->     deriving instance Eq Gender
->     deriving instance Eq (Person a_adHv)
->     deriving instance (Eq a_adHu, Eq a_adHu) => Eq (Department a_adHu)
->     deriving instance Eq a_adHt => Eq (Company a_adHt)
->     deriving instance Ord Gender
->     deriving instance Ord (Person a_adHv)
->     deriving instance (Ord a_adHu, Ord a_adHu) =>
->                       Ord (Department a_adHu)
->     deriving instance Ord a_adHt => Ord (Company a_adHt)
->     deriving instance Generic Gender
->     deriving instance Generic (Person a_adHv)
->     deriving instance Generic (Department a_adHu)
->     deriving instance Generic (Company a_adHt)
-
-
-This will make sense if you have a deep composited data types, nomally an AST of a language.
-
-'instance_' and 'instances' functions will generate empty instances. It is not quite useful with GHC newer than 7.10 with 'DeriveAnyClass' extension. However, with older GHC, it may help. The useage is the same with 'deriving' and 'derivings'.
-
-* __NOTE!__ This is not tested with GHC 7.8.
-
-For other classes whose instance can only be generated by using a function with type @Name -> Q [Dec]@ like 'Arbitrary' in 'QuickCheck', the @derive@ package provides @derive makeArbitrary@ function. For doing the top-down derive in these cases, 'deriving_th' and 'deriving_ths' are defined. Other example can the @deriveXXXX@ functions in @Data.Aeson.TH@.
-
-> deriving_th (''FromJSON, deriveFromJSON defaultOptions) ''Company
-> deriving_th (''ToJSON, deriveToJSON defaultOptions)     ''Company
-
-However, the poblem could be that the instance context is generated by the template haskell derive function instead mine, so it could be wrong in some circumtances. For example, a type with high order type constructor:
-
-> data T1 k a b = T11 (k a) b | T12 (k (k b)) a b Int
-
-It cannot be derived 'FromJSON' and 'ToJSON' with 'deriveFromJSON' and 'deriveToJSON' since it does not generate @(k a)@ and @(k (k b))@ for in the instance context.
-
-Also, there are some data types which are impossible to be derived as instances of a certain type class. For example, Word cannot be derived as Functor or Generic. Using @derive-topdown@ is the same with hand-written code, so it is your responsiblity to make that right.
-
-* __NOTE!__ @derive-topdown@ works with 'Typeable' type class, but there might be problems. Use @AutoDeriveTypeable@ extension if you want derive 'Typeable' class. See README and [here](https://ghc.haskell.org/trac/ghc/ticket/11251).
-
-* __NOTE!__ When derive @Generic@ type class, @derive-topdown@ will stop generation on primitive and 'Integer' types. You need to specify the types that deriving @Generic@ class can break with. See the document below.
-
--}
-
-module Data.Derive.TopDown (
-  module Data.Derive.TopDown.Standalone,
-  module Data.Derive.TopDown.Instance,
-  module Data.Derive.TopDown.TH
-#if __GLASGOW_HASKELL__ >= 802
-   ,stock, anyclass, newtype_
-   ,DerivStrategy(StockStrategy,AnyclassStrategy,NewtypeStrategy)
-#endif
-  )
-
-where
-#if __GLASGOW_HASKELL__ >= 802
-import Language.Haskell.TH.Syntax
-#endif
-import Data.Derive.TopDown.Standalone
-import Data.Derive.TopDown.Instance
-import Data.Derive.TopDown.TH
-
-#if __GLASGOW_HASKELL__ >= 802
-{-|
-The name @sock@ and @anyclass@ are still allowed to be used as functions or arguments. See <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies>
--}
-stock     = StockStrategy
-anyclass  = AnyclassStrategy
-newtype_  = NewtypeStrategy
-#endif
+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown (+   module Data.Derive.TopDown.Standalone+ , module Data.Derive.TopDown.Instance+ , module Data.Derive.TopDown.TH+ , module Data.Derive.TopDown.CxtGen+ , char, int, int8, int16, int32, int64, word, word8, word16, word32, word64+ , primitives, state, realWorld+#if __GLASGOW_HASKELL__ >= 802+ , stock, anyclass, newtype_+ , DerivStrategy(StockStrategy, AnyclassStrategy, NewtypeStrategy)+#endif+)+where++#if __GLASGOW_HASKELL__ >= 802+import Language.Haskell.TH.Syntax+#endif+import Data.Derive.TopDown.Standalone+import Data.Derive.TopDown.Instance+import Data.Derive.TopDown.TH+import Data.Derive.TopDown.CxtGen++#if __GLASGOW_HASKELL__ >= 802+{-|+The name @sock@ and @anyclass@ are still allowed to be used as functions or arguments. +See <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies>+-}+stock, anyclass, newtype_ :: DerivStrategy+stock     = StockStrategy+anyclass  = AnyclassStrategy+newtype_  = NewtypeStrategy+#endif++-- | Primitive types with hashes that may cause to stop the generation process+char, int, int8, int16, int32, int64, word, word8, word16, word32, word64 :: Name+char   = Name (mkOccName "Char#")   (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+int    = Name (mkOccName "Int#")    (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+int8   = Name (mkOccName "Int8#")   (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+int16  = Name (mkOccName "Int16#")  (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+int32  = Name (mkOccName "Int32#")  (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+int64  = Name (mkOccName "Int64#")  (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+word   = Name (mkOccName "Word#")   (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+word8  = Name (mkOccName "Word8#")  (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+word16 = Name (mkOccName "Word16#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+word32 = Name (mkOccName "Word32#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+word64 = Name (mkOccName "Word64#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))++-- | list of @Name@: @[char, int, int8, int16, int32, int64, word, word8, word16, word32, word64]@+primitives :: [Name]+primitives = [char, int, int8, int16, int32, int64, word, word8, word16, word32, word64]++-- | @GHC.Prim.State#@ type+state :: Name+state  = Name (mkOccName "State#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))++-- | @GHC.Prim.RealWorld#@ type+realWorld :: Name+realWorld  = Name (mkOccName "RealWorld#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))

@@ -0,0 +1,328 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.CxtGen+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Data.Derive.TopDown.CxtGen+  ( genInferredContext+  , genHoleContext+  , genAllFieldsContext+  ) where++{-+-- This module contains functions with type ClassName -> TypeName -> Type++    There are 2 ways +    1. deriving by making the context with all wholes with @PartialTypeSignatures@++    ```+    deriving instance _ => Eq (A a)++    ```+    +    2. deriving by generate the class context which can handle type family+-}++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Control.Monad.State+import qualified Control.Monad.Trans           as T+import           Data.Derive.TopDown.Lib+import qualified Data.List                     as L+import qualified Data.Map                      as M+import           Data.Map                       ( (!)+                                                , delete+                                                , insert+                                                )+import           Data.Map                       ( Map )+import           Data.Maybe+import qualified Data.Set                      as S+import           Data.Set                       ( Set )+import           GHC.Generics+import           Language.Haskell.TH++data Env = Env+  { inferring    :: [Name]             -- ^ encountered types during infer process+  , parameters   :: Map Name [Name]      -- ^ type parameters list+  , fields       :: Map Name (Set Type)  -- ^ the context+  , substitution :: Map Name (Map Type [(Type, Type)])   -- ^ caller indexed substitution+  , inferred     :: Map Name (Set Type)  -- ^ inferred context of types+  }+  deriving (Eq, Show)++putSubst :: Name -> Type -> [(Type, Type)] -> Env -> Env+putSubst n t s e =+  let subs = substitution e+  in  if M.member n subs+        then+          -- find the its t2tt and insert+          let new_t2tt = M.insert t s (subs ! n)+          in  e { substitution = M.insert n new_t2tt subs }+        else e { substitution = M.insert n (M.singleton t s) subs }++putInferringType :: Name -> Env -> Env+putInferringType n e = e { inferring = n : inferring e }++putParameters :: Name -> [Name] -> Env -> Env+putParameters n ns e = e { parameters = M.insert n ns (parameters e) }++putFields :: Name -> Set Type -> Env -> Env+putFields n ts e = e { fields = M.insert n ts (fields e) }+++deleteInferring :: Name -> Env -> Env+deleteInferring n e = e { inferring = L.delete n (inferring e) }++moveFieldsToInferred :: Name -> Env -> Env+moveFieldsToInferred n e =+  let ts = fields e ! n+      f' = delete n (fields e)+      i' = insert n ts (inferred e)+  in  e { fields = f', inferred = i' }++-- | Context Infer Monad+type CIM a = StateT Env Q a++initEnv :: Env+initEnv = Env { inferring    = []+              , parameters   = M.empty+              , fields       = M.empty+              , substitution = M.empty+              , inferred     = M.empty+              }++isWholeTypeContext :: Type -> Q Bool+isWholeTypeContext (VarT _) = return True+-- TODO: Here I will not rewrite fully applied type family+-- and just put the type family application into context.+-- In the future it should be changed.+isWholeTypeContext v =+  (||) <$> isLeftMostAppTTypeFamily v <*> isLeftMostAppTTypeVar v++doesFieldContainPotentialContext :: Type -> Q Bool+doesFieldContainPotentialContext t = case t of+  ForallT _ _ _        -> return True+#if __GLASGOW_HASKELL__ >= 810+  ForallVisT _       _ -> return True+#endif+  a@(        AppT _ _) -> do+    is_ty_fam_or_var <-+      (||) <$> isLeftMostAppTTypeFamily a <*> isLeftMostAppTTypeVar a+    if is_ty_fam_or_var+      then return True+      -- if it not var then it can be tuple, list, ConT+      -- for those types if no type variables such as +      -- (Int, Bool), Maybe Char in it then it should not be+      -- in the context.+      else if null $ getAllVarNames t then return False else return True+#if __GLASGOW_HASKELL__ >= 808+  AppKindT ty _  -> doesFieldContainPotentialContext ty+#endif+  SigT     ty _  -> doesFieldContainPotentialContext ty+  VarT      _    -> return True+  ConT      _    -> return False+  PromotedT _    -> error "impossible field for PromotedT"+  InfixT t1 _ t2 -> liftA2 (||)+                           (doesFieldContainPotentialContext t1)+                           (doesFieldContainPotentialContext t2)+  UInfixT         _ _ _ -> error "impossible field for UInfixT"+#if __GLASGOW_HASKELL__ >= 904+  PromotedInfixT  _ _ _ -> error "impossible field for PromotedInfixT"+  PromotedUInfixT _ _ _ -> error "impossible field for PromotedUInfixT"+#endif+  ParensT       ty      -> doesFieldContainPotentialContext ty+  TupleT        _       -> error "impossible field for TupleT"+  UnboxedTupleT _       -> error "impossible field for UnboxedTupleT"+  UnboxedSumT   _       -> error "impossible field for UnboxedSumT"+  ArrowT                -> undefined -- should put app of Arrow into context?+#if __GLASGOW_HASKELL__ >= 900+  MulArrowT             -> undefined+#endif+  EqualityT             -> error "impossible field for EqualityT"+  ListT                 -> error "impossible field for ListT"+  PromotedTupleT _      -> error "impossible field for PromotedTupleT"+  PromotedNilT          -> error "impossible field for PromotedNilT"+  PromotedConsT         -> error "impossible field for PromotedConsT"+  StarT                 -> error "impossible field for StarT"+  ConstraintT           -> error "impossible field for ConstraintT"+  LitT _                -> error "impossible field for LitT"+  WildCardT             -> error "impossible field for WildCardT"+#if __GLASGOW_HASKELL__ >= 808+  ImplicitParamT _ _    -> error "impossible field for ImplicitParamT"+#endif++-- | a lazily applied type paramters lookup function+getParams :: TypeName -> CIM [Name]+getParams tn = do+  env <- get+  let n2p = parameters env+  if M.member tn n2p+    then return $ n2p ! tn+    else do+      (tvs, _) <- T.lift (getTyVarFields tn)+      let tv_names = map getTVBName tvs+      modify (putParameters tn tv_names)+      return tv_names++-- find base case of recursive functions+-- handle type synonym?+inferContext :: TypeName -> CIM (Set Type)+inferContext tn = do+  -- check the global context+  env <- get+  let it = inferred env+  if M.member tn it+    -- already inferred+    then return $ fromJust $ M.lookup tn it+    else do+      -- put tn into list of type chain+      modify (putInferringType tn)+      -- get all cons+      (_, all_fields) <- lift (getTyVarFields tn)+      -- get all constructor types and replace all forall quantifiers+      let fs = map replaceForallTWithAny all_fields+      fs_without_type_sym <- lift $ mapM noWarnExpandSynsWith fs+      ts <- lift $ filterM doesFieldContainPotentialContext fs_without_type_sym+      all_sat <- lift $ fmap and (traverse isWholeTypeContext ts)+      modify (putFields tn (S.fromList ts))+      if all_sat+        then do+          -- put into inferred and remove it from context+          -- this is the basecase of this recursive function+          modify (moveFieldsToInferred tn)+          -- remove it from inferring+          modify (deleteInferring tn)+          return $ S.fromList ts+        else do+          apply_until_fix_point tn+          -- put result into inferred+          modify (moveFieldsToInferred tn)+          modify (deleteInferring tn)+          e <- get+          let tn_context = S.toList $ inferred e ! tn+          -- since mutual recursive declarations will substitute the+          -- type back and forth, they need to be removed.+          tn_context' <- lift $ filterM+            (\x -> do+              is_data <- isLeftMostAppTDataNewtype x+              return $ not is_data+            )+            tn_context+          return $ S.fromList tn_context'++apply_until_fix_point :: Name -> CIM ()+apply_until_fix_point tn = do+  env <- get+  let tn_fields = fields env ! tn+  gen_subst tn+  subst_data_newtype tn+  env' <- get+  let tn_fields' = fields env' ! tn+  if tn_fields == tn_fields' then return () else apply_until_fix_point tn++-- put fields of data or newtype fields into map+gen_subst :: Name -> CIM ()+gen_subst tn = do+  env <- get+  let fs = S.toList $ fields env ! tn+  context_type <- lift $ filterM+    (\x ->+      (||)+        <$> (isLeftMostAppTDataNewtype x)+        <*> (return $ isLeftMostBuildInContextType x)+    )+    fs+  forM_ context_type $ \t -> case getLeftMostType t of+    ConT ctn -> do+      let it = inferring env+      is_recursive <- if elem ctn it+        then do+          return True+        else do+          _ <- inferContext ctn+          return False+      -- construct substitution map+      let args = getConstrArgs t+      param_names <- (fmap . map) VarT (getParams ctn)+      assert (length args == length param_names)+             (modify (putSubst tn t (zip param_names args)))+      -- remove recursive type from fields+      if is_recursive+        then do+          let new_fields = S.delete t (S.fromList fs)+          modify (putFields tn new_fields)+        else return ()+    ListT -> do+      let arg             = getConstrArgs t+      let list_param_name = [VarT $ mkName "a"]+      assert (length arg == length list_param_name)+             (modify (putSubst tn t (zip list_param_name arg)))+    TupleT n -> do+      let args = getConstrArgs t+      let tup_param_names =+            map (VarT . mkName) [ 'a' : show x | x <- [1 .. n] ]+      assert (length args == length tup_param_names)+             (modify (putSubst tn t (zip tup_param_names args)))+    err_t -> error $ "gen_subst does not support type: " ++ show err_t++subst_data_newtype :: Name -> CIM ()+subst_data_newtype tn = do+  env <- get+  let tn_substs = M.toList $ substitution env ! tn+  forM_ tn_substs $ \(t, t2t) -> case getLeftMostType t of+    ConT ctn -> do+      e <- get+      let tn_fields_map = fields e+      let tn_inferred   = inferred e+      let ctn_context =+            fromJust $ M.lookup ctn tn_fields_map <|> M.lookup ctn tn_inferred+      let new_context = substituteVarsTypes t2t (S.toList ctn_context)+      new_context' <- lift+        $ filterM doesFieldContainPotentialContext new_context+      let new_tn_fields =+            S.union (S.fromList new_context') (S.delete t (fields e ! tn))+      modify $ putFields tn new_tn_fields+    ListT -> do+      e <- get+      let arg = getConstrArgs t+      new_context <- lift $ filterM doesFieldContainPotentialContext arg+      let new_tn_fields =+            S.union (S.fromList new_context) (S.delete t (fields e ! tn))+      modify $ putFields tn new_tn_fields+    TupleT _ -> do+      e <- get+      let args = getConstrArgs t+      new_context <- lift $ filterM doesFieldContainPotentialContext args+      let new_tn_fields =+            S.union (S.fromList new_context) (S.delete t (fields e ! tn))+      modify $ putFields tn new_tn_fields+    err_ty ->+      error $ "subst_data_newtype does not support type: " ++ show err_ty++genInferredContext :: ClassName -> TypeName -> Q Cxt+genInferredContext cn tn = if cn == ''Generic+  then return []+  else do+    ts <- fmap S.toList (evalStateT (inferContext tn) initEnv)+    return $ map (\t -> AppT (ConT cn) t) ts++-- | Generate wildcard context +genHoleContext :: ClassName -> TypeName -> Q Cxt+genHoleContext _ _ = return [WildCardT]++-- | Put all possible type fields of the type into context+genAllFieldsContext :: ClassName -> TypeName -> Q Cxt+genAllFieldsContext cn tn = if cn == ''Generic+  then return []+  else do+    (_, types) <- getTyVarFields tn+    ts         <- filterM doesFieldContainPotentialContext types+    let csts = map (\t -> AppT (ConT cn) t) ts+    return csts

@@ -1,57 +1,105 @@-{-# LANGUAGE TemplateHaskell #-}
-module Data.Derive.TopDown.Instance (instance_, instances, instancess) where
-
-import Data.Derive.TopDown.Lib
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax hiding (lift)
-import qualified GHC.Generics as G
-import Control.Monad
-import Control.Monad.Trans
-import Control.Monad.State
-import Data.List (foldl')
-import Data.Primitive.Types
-
-genEmptyInstanceDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec]
-genEmptyInstanceDecl cn tn = do
-                   (tvbs,cons) <- getTyVarCons cn tn
-                   classContext <- lift $ generateClassContext cn tn
-                   let typeNames = map getTVBName tvbs
-                   instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames
-                   -- Stop generating further instances
-                   -- 1. it is already a member of that type class
-                   -- 2. we have already generated it, which is kind of same with case 1
-                   -- 3. for GHC.Generic, if it is a primitive type like Int, Double
-                   isMember <- lift $ isInstance' cn [instanceType]              
-                   isPrimitive <-lift $ isInstance ''Prim [instanceType]
-                   let isGeneric = ''G.Generic == cn             
-                   table <- get
-                   if isMember || elem instanceType table || (isPrimitive && isGeneric)
-                     then return []
-                     else do
-                       let context = case classContext of
-                                       Nothing -> []
-                                       Just cc -> if isGeneric then [] else [cc]
-#if __GLASGOW_HASKELL__> 710                                       
-                       let c = [InstanceD Nothing context (AppT (ConT cn) instanceType) []]
-#else
-                       let c = [InstanceD context (AppT (ConT cn) instanceType) []]
-#endif
-                       modify (instanceType:)
-                       names <- lift $ fmap concat $ mapM getCompositeTypeNames cons
-                       xs <- mapM (\n -> genEmptyInstanceDecl cn n) names
-                       return $ concat xs ++ c
-
-instance_ :: Name -- ^ class name
-          -> Name -- ^ type name
-          -> Q [Dec]
-instance_ cn tn = evalStateT (genEmptyInstanceDecl cn tn) []
-
-instances :: [Name] -- ^ class names
-          -> Name   -- ^ type name
-          -> Q [Dec]
-instances cns tn = fmap concat (mapM (\x -> instance_ x tn) cns)
-
-instancess :: [Name] -- ^ class names
-           -> [Name] -- ^ type names
-           -> Q [Dec]
-instancess cns tns = fmap concat (mapM (\x -> instances cns x) tns)
+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.Instance+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown.Instance+  ( instance_+  , instance_with_breaks+  , instances+  , instancess+  , instance_with+  ) where++import           Control.Monad+import           Control.Monad.State+import           Data.Derive.TopDown.CxtGen     ( genInferredContext )+import           Data.Derive.TopDown.IsInstance+import           Data.Derive.TopDown.Lib+import           Data.List                      ( foldl1' )+import           Language.Haskell.TH++gen_instance_decl+  :: ClassName+  -> TypeName+  -> [TypeName]  -- ^ a list of types that breaks the generation process+  -> Maybe Overlap+  -> ContextGenderator -- ^ a context generator+  -> StateT [Type] Q [Dec]+gen_instance_decl cn tn breaks mo cg = do+  (tvbs, cons) <- lift $ getTyVarCons tn+  let typeNames = map getTVBName tvbs+  isCnHighOrderClass <- lift $ isHigherOrderClass cn+  -- prevent calling isInstance class with * -> * and type with *+  if isCnHighOrderClass && null typeNames+    then return []+    else do+      saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames)+      instanceType  <- if isCnHighOrderClass && (not . null) typeNames+        then+          let pns = init typeNames+          in  if null pns+                then lift $ conT tn+                else lift $ foldl1' appT (conT tn : (map varT pns))+        else return saturatedType+      isMember <- lift $ isInstance' cn [instanceType]+      table    <- get+      if isMember || elem instanceType table || elem tn breaks+         -- normally empty instance will not be used to derive Generic+         -- so I do not check Generic and Generic1+        then return []+        else do+          classContext <- if isCnHighOrderClass+            then return []+            else lift $ cg cn tn+          let decl =+                [InstanceD mo classContext (AppT (ConT cn) instanceType) []]+          modify (instanceType :)+          names  <- lift $ fmap concat $ mapM getCompositeTypeNames cons+          names' <- lift+            $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names+          xs <- mapM (\n -> gen_instance_decl cn n breaks mo cg) names'+          return $ concat xs ++ decl++instance_+  :: Name -- ^ class name+  -> Name -- ^ type name+  -> Q [Dec]+instance_ cn tn =+  evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext) []++instance_with_breaks+  :: Name -- ^ class name+  -> Name -- ^ type name+  -> [Name] -- ^ type names that stop the deriving process+  -> Q [Dec]+instance_with_breaks cn tn bs =+  evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext) []++instances+  :: [Name] -- ^ class names+  -> Name   -- ^ type name+  -> Q [Dec]+instances cns tn = fmap concat (mapM (\x -> instance_ x tn) cns)++instancess+  :: [Name] -- ^ class names+  -> [Name] -- ^ type names+  -> Q [Dec]+instancess cns tns = fmap concat (mapM (\x -> instances cns x) tns)++instance_with+  :: ClassName+  -> TypeName+  -> [TypeName]        -- ^ a list of types that breaks the generation process+  -> Maybe Overlap+  -> ContextGenderator -- ^ a context generator+  -> Q [Dec]+instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg) []

@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.IsInstance+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown.IsInstance+  ( isInstance'+  ) where++import           Data.Derive.TopDown.Lib+import           Data.Generics+import           GHC.Exts+{-+Note:+  Since GHC template-haskell isInstance function cannot work with +  polymorphic type. It cannot check whether @Eq a => [a]@ is an +  instance of 'Eq', here +  +  >poly_a :: Q Bool+  >poly_a = do+  >    poly_a_t <- [t| forall a. Eq a => [a] |]+  >    isInstance ''Eq [poly_a_t]+  > $(poly_a >>= stringE.show)+  >"False"+  >poly_a' :: Q Bool+  >poly_a' = do+  >    poly_a_t <- [t| forall a. [a] |]+  >    isInstance ''Eq [poly_a_t]+  > $(poly_a >>= stringE.show)+  >"False"+  +  So, here I change all the polymorphic types in the type into 'Any'++  @type family Any :: k where {}@++  See https://gitlab.haskell.org/ghc/ghc/-/issues/10607+-}+import           Language.Haskell.TH++replace_poly_type :: Type -> Type+replace_poly_type (VarT _) = ConT ''Any+replace_poly_type x        = x++replace_poly_type_trans :: Data a => a -> a+replace_poly_type_trans = everywhere (mkT replace_poly_type)++remove_explicit_forall :: Type -> Type+remove_explicit_forall (ForallT _ _ t) = t+remove_explicit_forall t               = t++remove_explicit_forall_trans :: Type -> Type+remove_explicit_forall_trans = everywhere (mkT remove_explicit_forall)++isInstance' :: ClassName -> [Type] -> Q Bool+isInstance' cls tys = if cls == ''Typeable+                        -- After GHC 7.10, GHC will generate Typeable +                        -- instance for all types, so this could be fine.+  then return True+  else+    let trans = remove_explicit_forall_trans . replace_poly_type_trans+    in  isInstance cls (map trans tys)

@@ -1,280 +1,335 @@-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE CPP #-}
-module Data.Derive.TopDown.Lib (
-  isInstance'
- , generateClassContext
- , getTyVarCons,getTVBName
- , getCompositeTypeNames
- , ClassName
- , TypeName
- , decType
- , DecTyType(..)
- ,getTypeConstructor
- ) where
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax hiding (lift)
-import Data.Generics (mkT,everywhere,mkQ,everything)
-import GHC.Exts
-import Language.Haskell.TH.ExpandSyns (expandSyns)
-import Data.List (nub,intersect,foldr1)
-import Control.Monad.State
-import Control.Monad.Trans
-#ifdef __GLASGOW_HASKELL__
-import Data.Typeable
-import Data.Data
-#endif
--- `isInstance` in template library does not work with polymorphic types.
--- The follwoing is an isInstance function with polymorphic type replaced by Any in GHC.Exts so that it can work with polymorphic type.
--- This is inspired by Ryan Scott
--- see https://ghc.haskell.org/trac/ghc/ticket/10607
--- isInstance will not work with Typeable.
--- See https://ghc.haskell.org/trac/ghc/ticket/11251
-
--- For fixing deriving Typeable problem, I use Data type calss to replace Typeable since the are always pairing with each other.
--- So if the data type is already an instance of Typeable and not an instance of Data, this might not work.
-isInstance' :: Name -> [Type] -> Q Bool
-isInstance' className tys =
-               if className == ''Typeable
-                then
-                 isInstance' ''Data tys
-                else
-                 isInstance className (map (removeExplicitForAllTrans. replacePolyTypeTrans) tys)
-
-replacePolyType :: Type -> Type
-replacePolyType (VarT t) = ConT ''Any
-replacePolyType x = x
-
-replacePolyTypeTrans = everywhere (mkT replacePolyType)
-
-removeExplicitForAll :: Type -> Type
-removeExplicitForAll (ForallT _ _ t) = t
-removeExplicitForAll t = t
-
-removeExplicitForAllTrans :: Type -> Type
-removeExplicitForAllTrans = everywhere (mkT removeExplicitForAll)
-
-getVarName :: Type -> [Name]
-getVarName (VarT n) = [n]
-getVarName _ = []
-
-getAllVarNames :: Type -> [Name]
-getAllVarNames = everything (++) (mkQ [] getVarName)
-
-constructorTypesVars :: [(Name, Role)] -> Type -> [Type]
--- get all free variablein a forall type expression.
-#if __GLASGOW_HASKELL__ > 810
-constructorTypesVars n2r  f@(ForallT tvbs _ t) = let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in
-                                              filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)
-                                              (constructorTypesVars n2r t)
-#else
-constructorTypesVars n2r  f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in
-                                              filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)
-                                              (constructorTypesVars n2r t)
-
-#endif
-
-constructorTypesVars n2r a@(AppT (VarT tvn) t2) = [a]
-constructorTypesVars n2r  c@(AppT (ConT name) t) = constructorTypesVars n2r t
-constructorTypesVars n2r  c@(AppT t1 t2) = constructorTypesVars n2r  t1 ++ constructorTypesVars n2r t2
-constructorTypesVars n2r  v@(VarT name) = case lookup name n2r of
-                                               Just PhantomR -> []
-                                               _ -> [v]
-constructorTypesVars n2r  c@(ConT name) = []
-constructorTypesVars n2r  (PromotedT name) = []
-#if __GLASGOW_HASKELL__ > 710
-constructorTypesVars n2r  (InfixT t1 name t2) = constructorTypesVars n2r t1 ++ constructorTypesVars n2r t2
-constructorTypesVars n2r  (UInfixT t1 name t2) = constructorTypesVars n2r t1 ++ constructorTypesVars n2r t2
-constructorTypesVars n2r  (ParensT t) = constructorTypesVars n2r t
-#endif
-constructorTypesVars n2r  (TupleT i) = []
-constructorTypesVars n2r  (ListT ) = [] 
--- constructorTypesVars n2r  (UnboxedTupleT i) = undefined
--- constructorTypesVars n2r  (UnboxedSumT t) = undefined -- ghc 8.2.1
-constructorTypesVars n2r  (EqualityT) = []
-constructorTypesVars n2r  (PromotedTupleT i) = []
-constructorTypesVars n2r  (PromotedNilT) = []
-constructorTypesVars n2r  (PromotedConsT) = []
-constructorTypesVars n2r  (LitT lit) = []
-constructorTypesVars n2r  (ConstraintT) = []
--- constructorTypesVars n2r  (WildCardT lit) = undefined
-constructorTypesVars n2r  (ArrowT) = []
-constructorTypesVars n2r  t = error $ pprint t ++ " is not support"
-
-expandSynsAndGetContextTypes :: [(Name, Role)] -> Type -> Q [Type]
-expandSynsAndGetContextTypes n2r t = do
-                             t' <- expandSyns t
-                             return $ (constructorTypesVars n2r  t')
-
-third (a,b,c) = c
-
-getContextType :: [(Name, Role)] -> Con -> Q [Type]
-getContextType name2role (NormalC name bangtypes) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd bangtypes)
-getContextType name2role (RecC name varbangtypes) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map third varbangtypes)
-getContextType name2role (InfixC bangtype1 name bangtype2) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd [bangtype1, bangtype2])
--- need to remove types which contains scoped variables
-#if __GLASGOW_HASKELL__>810
-getContextType name2role (ForallC tvbs _ con) =  let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in
-                                         do
-                                           types <- (getContextType name2role) con
-                                           let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types
-                                           fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars
-#else
-
-getContextType name2role (ForallC tvbs _ con) =  let scopedVarNames = map getTVBName tvbs in
-                                         do
-                                           types <- (getContextType name2role) con
-                                           let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types
-                                           fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars
-#endif
-#if __GLASGOW_HASKELL__ > 710
-getContextType name2role (GadtC name bangtypes result_type) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd bangtypes)
-getContextType name2role (RecGadtC name bangtypes result_type) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map third bangtypes)
-#endif
-
-#if __GLASGOW_HASKELL__ > 810
-getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr ()], [Con])
-#else
-getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr], [Con])
-#endif
-getTyVarCons cn name = do
-            info <- lift $ reify name
-            case info of
-              TyConI dec -> case dec of
-#if __GLASGOW_HASKELL__ > 810
-                              DataD _ _ tvbs _ cons _  -> return (map voidTyVarBndrFlag tvbs, cons)
-                              NewtypeD _ _ tvbs _ con _-> return (map voidTyVarBndrFlag tvbs, [con])
-#endif
-#if __GLASGOW_HASKELL__ > 710 && __GLASGOW_HASKELL__ <= 810
-                              DataD _ _ tvbs _ cons _  -> return (tvbs, cons)
-                              NewtypeD _ _ tvbs _ con _-> return (tvbs, [con])
-#endif
-#if __GLASGOW_HASKELL__ <= 710 
-                              DataD _ _ tvbs cons _  -> return (tvbs, cons)
-                              NewtypeD _ _ tvbs con _-> return (tvbs, [con])
-#endif
-                              TySynD name tvbs t -> error $ show name ++ " is a type synonym and -XTypeSynonymInstances is not supported. If you did not derive it then This is a bug, please report this bug to the author of this package."
-                              x -> do
-                                 tys <- get
-                                 error $ pprint x ++ " is not a data or newtype definition. " ++ show "Stack: " ++ show tys
-              _ -> error $ "Cannot generate "++ show cn ++ " instances for " ++ show name
-
-type ClassName = Name
-type TypeName = Name
-
-#if __GLASGOW_HASKELL__ > 810
-voidTyVarBndrFlag :: TyVarBndr flag -> TyVarBndr ()
-voidTyVarBndrFlag (PlainTV n f) = PlainTV n ()
-voidTyVarBndrFlag (KindedTV n f k) = KindedTV n () k
-#endif
-
--- In the future of GHC, this will be removed.
--- See https://ghc.haskell.org/trac/ghc/ticket/13324
-generateClassContext :: ClassName -> TypeName -> Q (Maybe Type)
-generateClassContext classname typename = do
-                            (tvbs, cons) <- (evalStateT $ getTyVarCons classname typename) []
-                            -- Need to remove phantom types
-                            roles <- reifyRoles typename
-                            let varName2Role = zip (map getTVBName tvbs) roles
-                            types <- fmap nub $ fmap concat $ mapM (getContextType varName2Role) cons
-                            let len = length types
-                            if len == 0
-                              then return Nothing
-                              else do
-                                  -- Eq a, Eq b ...
-                                  let contexts = map (AppT (ConT classname)) types
-                                  -- (Eq a, Eq b ...)
-                                  let contextTuple = foldl1 AppT $ (TupleT len) : contexts
-                                  return $ Just contextTuple
-
-
-#if __GLASGOW_HASKELL__ > 810
-getTVBName :: TyVarBndr () -> Name
-getTVBName (PlainTV name _)   = name
-getTVBName (KindedTV name _ _) = name
-#else
-getTVBName :: TyVarBndr -> Name
-getTVBName (PlainTV name)   = name
-getTVBName (KindedTV name _) = name
-#endif
-
-
-getTypeNames :: Type -> [Name]
-getTypeNames (ForallT tvbs cxt t) = getTypeNames t
-getTypeNames (ConT n) = [n]
-getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2
-getTypeNames _ = []
-
-expandSynsAndGetTypeNames :: [Type] -> Q [TypeName]
-expandSynsAndGetTypeNames ts = do
-                          ts' <- mapM expandSyns ts
-                          return $ concatMap getTypeNames ts'
-
-getCompositeTypeNames :: Con -> Q [TypeName]
-getCompositeTypeNames (NormalC n bts) = expandSynsAndGetTypeNames (map snd bts)
-getCompositeTypeNames (RecC n vbts) = expandSynsAndGetTypeNames (map third vbts)
-getCompositeTypeNames (InfixC st1 n st2) = expandSynsAndGetTypeNames (map snd [st1 , st2])
-getCompositeTypeNames (ForallC bind context con) = getCompositeTypeNames con
-#if __GLASGOW_HASKELL__> 710
-getCompositeTypeNames (GadtC name bangtype resulttype) = expandSynsAndGetTypeNames (map snd bangtype)
-getCompositeTypeNames (RecGadtC name bangtypes result_type) = expandSynsAndGetTypeNames (map third bangtypes)
-#endif
-
-#if __GLASGOW_HASKELL__ > 810
-tvb2kind :: TyVarBndr a -> Kind
-tvb2kind (PlainTV n _) = StarT
-tvb2kind (KindedTV n _ kind) = kind 
-#else
-tvb2kind :: TyVarBndr -> Kind
-tvb2kind (PlainTV n) = StarT
-tvb2kind (KindedTV n kind) = kind 
-#endif
-
-
-data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Show, Enum, Eq)
-
-decType :: Name -> Q DecTyType
-decType name = do
-         info <- reify name
-         case info of
-           TyConI dec -> case dec of
-#if __GLASGOW_HASKELL__ > 710
-              DataD _ _ tvbs _ cons _   -> return Data
-              NewtypeD _ _ tvbs _ con _ -> return Newtype
-#else
-              DataD _ _ tvbs cons _   -> return Data                                               
-              NewtypeD _ _ tvbs con _ -> return Newtype
-#endif
-              TySynD name tvbs t -> return TypeSyn
-           PrimTyConI name arity unlifted -> return BuiltIn
-
-
--- A function which is not used
-getKind :: Name -> Q Kind
-getKind name = do
-         info <- reify name
-         case info of
-           TyConI dec -> case dec of
-#if __GLASGOW_HASKELL__ > 710
-              DataD _ _ tvbs _ cons _   -> case tvbs of
-                                                [] -> return StarT
-                                                xs -> return (foldr1 AppT (map tvb2kind xs))
-              NewtypeD _ _ tvbs _ con _ -> case tvbs of
-                                                [] -> return StarT
-                                                xs -> return (foldr1 AppT (map tvb2kind xs))
-#else
-              DataD _ _ tvbs cons _   -> case tvbs of
-                                                [] -> return StarT
-                                                xs -> return (foldr1 AppT (map tvb2kind xs))
-              NewtypeD _ _ tvbs con _ -> case tvbs of
-                                                [] -> return StarT
-                                                xs -> return (foldr1 AppT (map tvb2kind xs))
-#endif
-           PrimTyConI name arity unlifted -> case arity of
-                                                 -- Unlifted types are not considered here.
-                                                0 -> return StarT
-                                                n -> return (foldr1 (\x y -> AppT (AppT ArrowT x) y) (replicate arity StarT))
-
-getTypeConstructor :: Type -> Type
-getTypeConstructor (AppT a1 a2) = getTypeConstructor a1
+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes#-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.Lib+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown.Lib where ++import Language.Haskell.TH+import Language.Haskell.TH.Syntax hiding (lift)+import Data.Generics+import GHC.Exts+import Language.Haskell.TH.ExpandSyns (expandSynsWith,noWarnTypeFamilies,expandSyns)+import Data.List (nub)+import Control.Monad.State+import Control.Monad.Trans+import Control.Applicative+import Control.Monad+import Language.Haskell.TH.Datatype (+    ConstructorInfo(..),+    DatatypeInfo(..),+    reifyDatatype+    )++type ClassName = Name+type TypeName = Name++type ContextGenderator = ClassName -> TypeName -> Q Cxt++noWarnExpandSynsWith :: Type -> Q Type+noWarnExpandSynsWith = expandSynsWith noWarnTypeFamilies++{-|+  Get the type variable name.+-}+getVarName :: Type -> [Name]+getVarName (VarT n) = [n]+getVarName _ = []++{-|+  Get the type variable names.+-}+getAllVarNames :: Data a => a -> [Name]+getAllVarNames = everything (++) (mkQ [] getVarName)++substitute :: (Type, Type) -> Type -> Type+substitute (VarT m, t) x@(VarT n) = if n == m +                                    then t+                                    else x+substitute (VarT _, _) x = x+substitute (t, _) x = error $ "cannot substitute " ++ show t ++ " with " ++ show x++substituteVar :: (Type, Type) -> Type -> Type+substituteVar s = everywhere (mkT (substitute s))++substituteVars :: [(Type, Type)] -> Type -> Type+substituteVars ss y = foldr substituteVar y ss++substituteVarsTypes :: [(Type, Type)] -> [Type] -> [Type]+substituteVarsTypes ms ts = [substituteVars ms y| y <- ts]++{-|+  Is the type a type family+-}+isTypeFamily :: TypeName -> Q Bool+isTypeFamily tn = do+                info <- reify tn+                case info of+                  FamilyI (OpenTypeFamilyD _) _     -> return True+                  FamilyI (ClosedTypeFamilyD _ _) _ -> return True +                  _                                 -> return False++isDataNewtype :: TypeName -> Q Bool+isDataNewtype tn = do+                info <- reify tn+                case info of+                  TyConI (DataD _ _ _ _ _ _)    -> return True+                  TyConI (NewtypeD _ _ _ _ _ _) -> return True +                  _                             -> return False++{-+  For type appications like @(k a b)@, @Either Int a@, we always need to +  get the left most type in such cases+-}+getLeftMostType :: Type -> Type+getLeftMostType (AppT t1 _) = getLeftMostType t1+getLeftMostType (ParensT t)  = getLeftMostType t+getLeftMostType t            = t++isLeftMostAppTTypeFamily :: Type -> Q Bool+isLeftMostAppTTypeFamily (getLeftMostType -> ConT n) = isTypeFamily n+isLeftMostAppTTypeFamily _                           = return False++isLeftMostAppTTypeVar :: Type -> Q Bool+isLeftMostAppTTypeVar (getLeftMostType -> VarT _) = return True+isLeftMostAppTTypeVar _                           = return False++-- not sure how to handle ArrowT with deriving yet+isLeftMostAppTArrowT :: Type -> Bool+isLeftMostAppTArrowT (getLeftMostType -> ArrowT)  = True+#if __GLASGOW_HASKELL__ >= 900+isLeftMostAppTArrowT (getLeftMostType -> MulArrowT)  = True+#endif+isLeftMostAppTArrowT _ = False++isLeftMostBuildInContextType :: Type -> Bool+isLeftMostBuildInContextType (getLeftMostType -> TupleT _)  = True+isLeftMostBuildInContextType (getLeftMostType -> ListT)     = True+isLeftMostBuildInContextType _ = False+++isLeftMostAppTDataNewtype :: Type -> Q Bool+isLeftMostAppTDataNewtype (getLeftMostType -> ConT n) = isDataNewtype n+isLeftMostAppTDataNewtype _                           = return False++{-| +  Get type variable name+-}+#if __GLASGOW_HASKELL__ >= 900+getTVBName :: TyVarBndr a -> Name+getTVBName (PlainTV name _)    = name+getTVBName (KindedTV name _ _) = name+#else+getTVBName :: TyVarBndr -> Name+getTVBName (PlainTV name)    = name+getTVBName (KindedTV name _) = name+#endif++{-| After unapplying left most cannot be AppT and AppKindT, but can be InfixT or others -}+unappTy :: Type -> [Type]+unappTy (AppT t1 t2) = unappTy t1 ++ [t2]+#if __GLASGOW_HASKELL__ >= 808+unappTy (AppKindT ty _) = unappTy ty+#endif+unappTy t = [t]++getConstrArgs :: Type -> [Type]+getConstrArgs = tail . unappTy++#if __GLASGOW_HASKELL__ >= 900+voidTyVarBndrFlag :: TyVarBndr flag -> TyVarBndr ()+voidTyVarBndrFlag (PlainTV n _) = PlainTV n ()+voidTyVarBndrFlag (KindedTV n _ k) = KindedTV n () k+#else+voidTyVarBndrFlag :: TyVarBndr -> TyVarBndr+voidTyVarBndrFlag = id+#endif+++isHigherOrderClass :: ClassName -> Q Bool+isHigherOrderClass cn = do+    cla <- reify cn+    case cla of+        ClassI (ClassD _ _ vars _ _) _ +            -> case head vars of+#if __GLASGOW_HASKELL__ >= 900+                  KindedTV _ _ k -> do +#else+                  KindedTV _ k -> do +#endif+                              if k == StarT+                                then return False+                                else return True+                  _ -> error $ "Cannot reify kind of class " ++ show cn+        _ -> error $ show cn ++ " is not a class"++getGadtCon :: Con -> [Con]+getGadtCon g@(GadtC _ _ _) = [g]+getGadtCon g@(RecGadtC _ _ _) = [g]+getGadtCon _ = []++getAllGadtCons :: Data a => a -> [Con]+getAllGadtCons = everything (++) (mkQ [] getGadtCon)++isGadt :: [Con] -> Bool+isGadt cons = not $ null $ concatMap getAllGadtCons cons+++constrInfoGadtC :: ConstructorInfo -> Con+constrInfoGadtC = undefined++-- ^ Get all fields of constructors+getAllConsFields :: [Con] -> [Type]+getAllConsFields cons = nub $ concatMap getAllConFields cons++getAllConFields :: Con -> [Type]+getAllConFields (NormalC _ bts          ) = map snd bts+getAllConFields (RecC    _ vbts         ) = map (\(_, _, x) -> x) vbts+getAllConFields (InfixC   bt1   _    bt2) = [snd bt1] ++ [snd bt2]+getAllConFields (ForallC  tvb   _  con)   = let ns = map (getTVBName. voidTyVarBndrFlag) tvb+                                              in getAllConFields (replaceVarInForallTypeTrans ns con)+-- https://gitlab.haskell.org/ghc/ghc/-/issues/13885#note_476439+getAllConFields (GadtC    _ _ _  ) = error "Should not use this to get fields of GADT"+getAllConFields (RecGadtC _ _ _  ) = error "Should not use this to get fields of GADT"++{-| data T a1 a2 = Con1 a1 | Con2 a2 ...+ return [a1, a2], [Con1 a1, Con2 a2]+-}+#if __GLASGOW_HASKELL__ >= 900+getTyVarCons :: TypeName -> Q ([TyVarBndr ()], [Con])+#else+getTyVarCons :: TypeName -> Q ([TyVarBndr], [Con])+#endif+getTyVarCons name = do+            info <- reify name+            case info of+              TyConI dec -> +                case dec of+                  DataD    _ _ tvbs _ cons _  -> return (map voidTyVarBndrFlag tvbs, cons)+                  NewtypeD _ _ tvbs _ con  _  -> return (map voidTyVarBndrFlag tvbs, [con])+                  TySynD   _ _ _        -> error $ show name ++ " is a type synonym and `TypeSynonymInstances' is not supported.\n"+                      ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package."+                  x -> do+                      error $ pprint (x :: Dec) ++ " is not a data or newtype definition."+              PrimTyConI _ _ _ -> return ([], [])+              x -> error $ show x ++ " is not supported"++#if __GLASGOW_HASKELL__ >= 900+getTyVarFields :: TypeName -> Q ([TyVarBndr ()], [Type])+#else+getTyVarFields :: TypeName -> Q ([TyVarBndr], [Type])+#endif+getTyVarFields name = do+            info <- reify name+            case info of+              TyConI dec -> +                case dec of+                  DataD    _ _ tvbs _ cons _ ->+                    -- GADT needs to rebind type variables+                    -- See https://gitlab.haskell.org/ghc/ghc/-/issues/13885+                    if isGadt cons+                      then do+                        t <- reifyDatatype name+                        let vars = datatypeVars t+                        let fields = concatMap constructorFields (datatypeCons t)+                        return (vars, fields)+                      else do+                        return $ (map voidTyVarBndrFlag tvbs, getAllConsFields cons)+                  NewtypeD _ _ tvbs _ con  _  -> return (map voidTyVarBndrFlag tvbs, getAllConsFields [con])+                  TySynD   _ _ _        -> error $ show name ++ " is a type synonym and `TypeSynonymInstances' is not supported.\n"+                      ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package."+                  x -> do+                      error $ pprint (x :: Dec) ++ " is not a data or newtype definition."+              _ -> error $ "Cannot generate instances for " ++ show name++getTypeConstructor :: Type -> Type+getTypeConstructor (AppT a1 _) = getTypeConstructor a1 getTypeConstructor a = a++reifyTypeParameters :: Name -> Q [Name]+reifyTypeParameters tn = do +                info <- reify tn+                case info of+                  TyConI (DataD _ _ tvb _ _ _)    -> return $ map getTVBName tvb+                  TyConI (NewtypeD _ _ tvb _ _ _) -> return $ map getTVBName tvb+                  _                             -> error "impossible case in reifyTypeParameters"+              +data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Show, Enum, Eq)++decType :: Name -> Q DecTyType+decType name = do+         info <- reify name+         case info of+           TyConI dec -> case dec of+              DataD _ _ _ _ _ _   -> return Data+              NewtypeD _ _ _ _ _ _ -> return Newtype+              TySynD _ _ _ -> return TypeSyn+              _ -> error $ "not a type declaration: " ++ show name+           PrimTyConI _ _ _ -> return BuiltIn+           _ ->  error $ "not a type declaration: " ++ show name +++getTypeNames :: Type -> [Name]+getTypeNames (ForallT _ _ t) = getTypeNames t+getTypeNames (ConT n) = [n]+getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2+getTypeNames _ = []++third :: (a, b, c) -> c+third (_,_,c) = c++expandSynsAndGetTypeNames :: [Type] -> Q [TypeName]+expandSynsAndGetTypeNames ts = do+                          ts' <- mapM noWarnExpandSynsWith ts+                          return $ concatMap getTypeNames ts'++getCompositeTypeNames :: Con -> Q [TypeName]+getCompositeTypeNames (NormalC _ bts) = expandSynsAndGetTypeNames (map snd bts)+getCompositeTypeNames (RecC _ vbts) = expandSynsAndGetTypeNames (map third vbts)+getCompositeTypeNames (InfixC st1 _ st2) = expandSynsAndGetTypeNames (map snd [st1 , st2])+getCompositeTypeNames (ForallC _ _ con) = getCompositeTypeNames con+getCompositeTypeNames (GadtC _ bangtype _) = expandSynsAndGetTypeNames (map snd bangtype)+getCompositeTypeNames (RecGadtC _ bangtypes _) = expandSynsAndGetTypeNames (map third bangtypes)++{-+Here, I just replace forall type into Any type since in the deriving clause generation+process, we cannot really do anything about the quantified type vars. +if @data C b = C (forall a. Show a => a) b@ need to derive Eq, it will failed anyway. +if user needs to derive @Show@ for @C@ the type @a@ does not matter here. We just need +@b@ in the context+-}+replace_var_in_forall_type :: [Name] -> Type -> Type+replace_var_in_forall_type ns v@(VarT n) = if n `elem` ns then ConT ''Any else v+replace_var_in_forall_type _ v = v++replaceVarInForallTypeTrans :: Data a => [Name] -> a -> a+replaceVarInForallTypeTrans ns = everywhere (mkT (replace_var_in_forall_type ns))++reset_forall_vars :: Type -> Type+reset_forall_vars (ForallT bs _ t) = let bns = map (getTVBName.voidTyVarBndrFlag) bs+                                         in replaceVarInForallTypeTrans bns t+#if __GLASGOW_HASKELL__ >= 810+reset_forall_vars (ForallVisT bs t) = let bns = map getTVBName bs+                                         in replaceVarInForallTypeTrans bns t +#endif+reset_forall_vars v = v++replaceForallTWithAny :: Type -> Type+replaceForallTWithAny = everywhere (mkT reset_forall_vars)

@@ -1,137 +1,166 @@-{-# LANGUAGE TemplateHaskell  #-}
-module Data.Derive.TopDown.Standalone (
-  deriving_, derivings, derivingss, deriving_with_breaks
-#if __GLASGOW_HASKELL__ >= 802
-  ,strategy_deriving
-  ,strategy_derivings
-  ,strategy_derivingss
-#endif
-  ) where
-
-import Data.Derive.TopDown.Lib
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax hiding (lift)
-import qualified GHC.Generics as G
-import Control.Monad
-import Control.Monad.Trans
-import Control.Monad.State
-import Data.List (foldl')
-import Data.Primitive.Types
-import Data.Typeable
-
-#if __GLASGOW_HASKELL__ >= 802
-genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec]
-genStandaloneDerivingDecl cn tn st breaks = do
-#else
-genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec]
-genStandaloneDerivingDecl cn tn breaks = do
-#endif
-                   (tvbs,cons) <- getTyVarCons cn tn
-                   classContext <- lift $ generateClassContext cn tn
-                   let typeNames = map getTVBName tvbs
-                   instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames
-                    -- Stop generating further instances
-                   -- 1. it is already a member of that type class
-                   -- 2. we have already generated it, which is kind of same with case 1
-                   -- 3. for GHC.Generic, if it is a primitive type like Int, Double
-                   -- 4. It will stop on the types in breaks
-                   -- 5. It will stop on primitive types and Integer when deriving Typeable
-                   isMember <- lift $ isInstance' cn [instanceType]              
-                   isPrimitive <-lift $ isInstance' ''Prim [instanceType]
-                   let isGeneric = ''G.Generic == cn
-                   table <- get
-                   if isMember || elem instanceType table || elem tn breaks ||
-                      (isPrimitive && isGeneric) || (isGeneric && tn == ''Integer) ||
-                      (cn == ''Typeable && isPrimitive) || (cn == ''Typeable && tn == ''Integer)
-                     then return []
-                     else do
-                       let context = case classContext of
-                                       Nothing -> []
-                                       Just cc -> if isGeneric then [] else [cc]
-#if __GLASGOW_HASKELL__ >= 802
-                       declareType <- lift (decType tn)
-                       let standaloneD = \strategy -> [StandaloneDerivD strategy context (AppT (ConT cn) instanceType)]
-                       let c = if st == Nothing
-                                 then standaloneD Nothing
-                                 else case declareType of
-                                         Data    -> case st of
-                                               Just NewtypeStrategy -> standaloneD Nothing
-                                               _                    -> standaloneD st
-                                         _       -> standaloneD st
-#else
-                       let c = [StandaloneDerivD context (AppT (ConT cn) instanceType)]
-#endif
-                       modify (instanceType:)
-                       names <- lift $ fmap concat $ mapM getCompositeTypeNames cons
-#if __GLASGOW_HASKELL__ >= 802
-                       xs <- mapM (\n -> genStandaloneDerivingDecl cn n st breaks) names
-#else
-                       xs <- mapM (\n -> genStandaloneDerivingDecl cn n breaks) names
-#endif
-                       return $ concat xs ++ c
-
-
-deriving_ :: Name -- ^ class name
-          -> Name -- ^ type name
-          -> Q [Dec]
-
-#if __GLASGOW_HASKELL__ >= 802
-deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn Nothing []) []
-#else
-deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) []
-#endif
-
-{- | This is particularly useful with 'Generic' class.
-
-For the types like 'Int', 'Char','Ratio' or other types which are not 'Generic', there must be a way to stop the generation process on those types.
-
-However, the deriving topdown function will only stop generating 'Generic' instances on primitive types and 'Integer' by default, so you do not need to break on them manually.
-
-Another circumtances might be deriving for 'Typeable' class. Since there is a bug in GHC, isInstance function in TH library is not working on 'Typeable', you can manually give the types which are already instances of 'Typeable' to stop the generation process.
-
-For others cases, there no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class.
--}
-deriving_with_breaks :: Name -- ^ class name
-          -> Name -- ^ type name
-          -> [Name] -- ^ type names that stop the deriving process
-          -> Q [Dec]
-
-#if __GLASGOW_HASKELL__ >= 802
-deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn Nothing bs) []
-#else
-deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn bs) []
-#endif
-
-
-derivings :: [Name] -- ^ class names
-          -> Name   -- ^ type name
-          -> Q [Dec]
-derivings cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns)
-
-derivingss :: [Name] -- ^ class names
-           -> [Name] -- ^ type names
-           -> Q [Dec]
-derivingss cns tns = fmap concat (mapM (\x -> derivings cns x) tns)
-
-
-#if __GLASGOW_HASKELL__ >= 802
-strategy_deriving :: DerivStrategy
-                  -> Name
-                  -> Name
-                  -> Q [Dec]
-
-strategy_deriving st cn tn = evalStateT (genStandaloneDerivingDecl cn tn (Just st) []) []
-
-strategy_derivings :: DerivStrategy
-                   -> [Name]
-                   -> Name
-                   -> Q [Dec]
-
-strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns)
-
-strategy_derivingss :: DerivStrategy
-                    -> [Name]
-                    -> [Name]
-                    -> Q [Dec]
-strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns)
-#endif
+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveGeneric #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.Standalone+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown.Standalone (+     deriving_+   , deriving_with_breaks+   , derivings+   , derivingss+   , deriving_with+#if __GLASGOW_HASKELL__ >= 802+   , strategy_deriving+   , strategy_derivings+   , strategy_derivingss+#endif+) ++where++import Data.Derive.TopDown.Lib+import Data.Derive.TopDown.CxtGen (genInferredContext)+import Language.Haskell.TH+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State+import Data.Derive.TopDown.IsInstance+import Data.List (foldl1')+import Data.Primitive.Types+import GHC.Generics+++reset_strategy :: TypeName -> Maybe DerivStrategy -> Q (Maybe DerivStrategy)+reset_strategy tn st = do+        declareType <- decType tn+        case (declareType, st) of+          (_, Nothing) -> return Nothing+          (Data, Just NewtypeStrategy) -> return Nothing+          _ -> return st++gen_standalone_deriving_decl :: ClassName +                          -> TypeName +                          -> Maybe DerivStrategy  +                          -> [TypeName]  -- ^ a list of types that breaks the generation process+                          -> ContextGenderator -- ^ a context generator+                          -> StateT [Type] Q [Dec]+gen_standalone_deriving_decl cn tn st breaks cg = do+                       (tvbs, cons) <- lift $ getTyVarCons tn+                       let typeNames = map getTVBName tvbs+                       isCnHighOrderClass <- lift $ isHigherOrderClass cn+                       -- prevent calling isInstance class with * -> * and type with *+                       if isCnHighOrderClass && null typeNames+                        then return []+                        else do+                           saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames)+                           instanceType <- if isCnHighOrderClass && (not . null) typeNames+                                                then let pns = init typeNames+                                                      in  if null pns+                                                            then lift $ conT tn+                                                            else lift $ foldl1' appT (conT tn : (map varT pns))+                                                else return saturatedType+                           -- Stop generating further instances+                           -- 1. it is already a member of that type class+                           -- 2. we have already generated it, which is kind of same with case 1+                           -- 3. for GHC.Generic, if it is a primitive type like Int, Double+                           -- 4. It will stop on the types in breaks+                           -- 5. It will stop on primitive types and Integer when deriving Typeable+                           isMember <- lift $ isInstance' cn [instanceType]+                           isPrimitive <-lift $ isInstance' ''Prim [saturatedType]+                           let isGeneric = ''Generic == cn+                           let isGeneric1 = ''Generic1 == cn+                           table <- get+                           if isMember || elem instanceType table || elem tn breaks ||+                              (isPrimitive && (isGeneric || isGeneric1)) || +                              (tn == ''Integer && (isGeneric || isGeneric1))+                              then return []+                              else do+                                 classContext <- if isCnHighOrderClass +                                                   then return []+                                                   else lift $ cg  cn tn+                                 s <- lift $ reset_strategy tn st+                                 let decl = [StandaloneDerivD s classContext (AppT (ConT cn) instanceType)]+                                 modify (instanceType:)+                                 names <- lift $ fmap concat $ mapM getCompositeTypeNames cons+                                 names' <- lift $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names+                                 xs <- mapM (\n -> gen_standalone_deriving_decl cn n st breaks cg) names'+                                 return $ concat xs ++ decl++deriving_ :: Name -- ^ class name+          -> Name -- ^ type name+          -> Q [Dec]+deriving_ cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext) []++{- | This is particularly useful with 'Generic' class.++For the types like 'Int', 'Char','Ratio' or other types which are not 'Generic', there must be a way to stop the generation process on those types.+However, the deriving topdown function will only stop generating 'Generic' instances on primitive types and 'Integer' by default, so you do not need to break on them manually.+Another circumtances might be deriving for 'Typeable' class. Since there is a bug in GHC, isInstance function in TH library is not working on 'Typeable', you can manually give the types which are already instances of 'Typeable' to stop the generation process.+For others cases, there no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class.+-}+deriving_with_breaks :: Name -- ^ class name+          -> Name -- ^ type name+          -> [Name] -- ^ type names that stop the deriving process+          -> Q [Dec]+deriving_with_breaks cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext) []++derivings :: [Name] -- ^ class names+          -> Name   -- ^ type name+          -> Q [Dec]+derivings cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns)++derivingss :: [Name] -- ^ class names+           -> [Name] -- ^ type names+           -> Q [Dec]+derivingss cns tns = fmap concat (mapM (\x -> derivings cns x) tns)+++#if __GLASGOW_HASKELL__ >= 802+strategy_deriving :: DerivStrategy+                  -> Name+                  -> Name+                  -> Q [Dec]++strategy_deriving st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext) []++strategy_derivings :: DerivStrategy+                   -> [Name]+                   -> Name+                   -> Q [Dec]++strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns)++strategy_derivingss :: DerivStrategy+                    -> [Name]+                    -> [Name]+                    -> Q [Dec]+strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns)+#endif++{-| Context generator ca be the following 3 + 1. genHoleContext: It requires PartialTypeSignatures to make the context of deriving+    context a `hole' e.g. @_ => Cls (D a b)@. This case cannot handle type family+    since GHC cannot handle it+ 2. genInferredContext: It will try to infer the context including cases with type families.+ 3. genAllFieldsContext: It will put all fields into the context. It may generate like the followings+ @+ data List a = Nil | Cons a (List a)+ deriving instance (Show a, Show (List a)) => Show (List a)+ @+-}+deriving_with :: ClassName +              -> TypeName +              -> Maybe DerivStrategy -- ^ deriving strategy+              -> [TypeName]        -- ^ a list of types that breaks the generation process+              -> ContextGenderator -- ^ a context generator,  @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@+              -> Q [Dec]+deriving_with cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg) []

@@ -1,45 +1,80 @@-{-# OPTIONS_GHC -ddump-splices #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Data.Derive.TopDown.TH (deriving_th, deriving_ths, deriving_thss) where
-import Data.Derive.TopDown.Lib
-
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax hiding (lift)
-
-import Control.Monad.State
-import Control.Monad.Trans
-import Data.List (foldl')
-
-genTH :: (ClassName, Name -> Q [Dec]) -> TypeName -> StateT [Type] Q [Dec]
-genTH (className,deriveFunction) typeName = do
-                       (tvbs, cons) <- getTyVarCons className typeName
-                       compositeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons
-                       let typeNames = map getTVBName tvbs
-                       instanceType <- lift $ foldl' appT (conT typeName) $ map varT typeNames
-                       isMember <- lift $ isInstance' className [instanceType]
-                       table <- get
-                       if isMember || elem instanceType table
-                          then return []
-                          else do
-                             decl <- lift $ deriveFunction typeName
-                             (modify (instanceType :))
-                             subTypeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons
-                             decls <- mapM (\n -> genTH (className,deriveFunction) n) subTypeNames
-                             return $ concat decls ++ decl
-
-
-deriving_th :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function
-           -> Name -- ^ type name
-           -> Q [Dec]
-deriving_th cd tname = evalStateT (genTH cd tname) []
-
-deriving_ths :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions
-            -> Name -- ^ type name
-            -> Q [Dec]
-deriving_ths cds typeName = fmap concat (mapM (\c -> deriving_th c typeName) cds)
-
-deriving_thss :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions
-             -> [Name] -- ^ type names
-             -> Q [Dec]
-deriving_thss cds typeNames = fmap concat (mapM (\t -> deriving_ths cds t) typeNames)
+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.TH+-- Copyright   :  (c) Song Zhang+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  haskell.zhang.song `at` hotmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------++module Data.Derive.TopDown.TH+  ( deriving_th+  , deriving_ths+  , deriving_thss+  , deriving_th_with+  ) where+import           Control.Monad.State+import           Data.Derive.TopDown.IsInstance ( isInstance' )+import           Data.Derive.TopDown.Lib+import           Data.List                      ( foldl1' )+import           Language.Haskell.TH++genTH+  :: (ClassName, Name -> Q [Dec])+  -> TypeName+  -> [TypeName]+  -> StateT [Type] Q [Dec]+genTH (className, deriveFunction) typeName bs = do+  (tvbs, cons) <- lift $ getTyVarCons typeName+  let typeNames = map getTVBName tvbs+  isCnHighOrderClass <- lift $ isHigherOrderClass className+  saturatedType      <- lift $ foldl1' appT (conT typeName : map varT typeNames)+  instanceType       <- if isCnHighOrderClass && (not . null) typeNames+    then+      let pns = init typeNames+      in  if null pns+            then lift $ conT typeName+            else lift $ foldl1' appT (conT typeName : (map varT pns))+    else return saturatedType+  isMember <- lift $ isInstance' className [instanceType]+  table    <- get+  if isMember || elem instanceType table || elem typeName bs+    then return []+    else do+      decl <- lift $ deriveFunction typeName+      modify (instanceType :)+      subTypeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons+      decls <- mapM (\n -> genTH (className, deriveFunction) n bs) subTypeNames+      return $ concat decls ++ decl++deriving_th+  :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function+  -> Name -- ^ type name+  -> Q [Dec]+deriving_th cd tname = evalStateT (genTH cd tname []) []++deriving_ths+  :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions+  -> Name -- ^ type name+  -> Q [Dec]+deriving_ths cds typeName =+  fmap concat (mapM (\c -> deriving_th c typeName) cds)++deriving_thss+  :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions+  -> [Name] -- ^ type names+  -> Q [Dec]+deriving_thss cds typeNames =+  fmap concat (mapM (\t -> deriving_ths cds t) typeNames)++deriving_th_with+  :: (ClassName, Name -> Q [Dec]) -- ^ class name and corresponding instance generation function+  -> TypeName    -- ^ type name+  -> [TypeName]  -- ^ type name list that breaks deriving process+  -> Q [Dec]+deriving_th_with cd tname bs = evalStateT (genTH cd tname bs) []

@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell, PolyKinds #-}+module Arity where+import           Data.Proxy+import           Language.Haskell.TH+++class TypeArity (cla :: k) where+    arity :: Proxy cla -> Integer++getTypeArity :: Name -> Q Int+getTypeArity name = do+  info <- reify name+  case info of+    TyConI dec -> case dec of+      DataD _ _ tvbs _ _ _ -> return $ length tvbs+      NewtypeD _ _ tvbs _ _ _ -> return $ length tvbs+      _ -> error "The type must be data, newtype definition!"+    PrimTyConI _ n _ -> return n+    x -> error $ show x ++ " is bad type name, quoted name is not a type!"++makeTypeArity :: Name -> Q [Dec]+makeTypeArity name = do+    at <- getTypeArity name+    [d| instance TypeArity $(conT name) where+            arity _ = at |]

@@ -0,0 +1,189 @@+{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}+++module Derive where+import           Control.Monad.IO.Class+import           Data.Derive.TopDown.IsInstance+import           Language.Haskell.Syntax+import           Language.Haskell.TH     hiding ( Exp )+import           Test.HUnit+import           Types+import           Utils++eqPerson = TestCase+  (assertEqual "Person is instance of Eq"+               True+               $((qBoolToExp $ isInstance' ''Eq [(ConT ''Person)]))+  )++ordPerson = TestCase+  (assertEqual "Person is instance of Ord"+               True+               $((qBoolToExp $ isInstance' ''Ord [(ConT ''Person)]))+  )++showCompany = TestCase+  (assertEqual "Company is instance of Show"+               True+               $((qBoolToExp $ isInstance' ''Show [(ConT ''Company)]))+  )++eqE0 = TestCase+  (assertEqual "E0 is instance of Eq"+               True+               $((qBoolToExp $ isInstance' ''Eq [(ConT ''E0)]))+  )++ordE0 = TestCase+  (assertEqual "E0 is instance of Ord"+               True+               $((qBoolToExp $ isInstance' ''Ord [(ConT ''E0)]))+  )++showE0 = TestCase+  (assertEqual "E0 is instance of Show"+               True+               $((qBoolToExp $ isInstance' ''Show [(ConT ''E0)]))+  )++eqT1 = TestCase+  (assertEqual "T1 is instance of Eq"+               True+               $((qBoolToExp $ isInstance' ''Eq [(ConT ''T1)]))+  )++ordT1 = TestCase+  (assertEqual "T1 is instance of Ord"+               True+               $((qBoolToExp $ isInstance' ''Ord [(ConT ''T1)]))+  )++showT1 = TestCase+  (assertEqual "T1 is instance of Show"+               True+               $((qBoolToExp $ isInstance' ''Show [(ConT ''T1)]))+  )++eqT2 = TestCase+  (assertEqual+    "T2 is instance of Eq"+    True+    $((qBoolToExp $ isInstance' ''Eq [apps [ConT ''T2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++ordT2 = TestCase+  (assertEqual+    "T2 is instance of Ord"+    True+    $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''T2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++ordT3 = TestCase+  (assertEqual+    "T3 is instance of Ord"+    True+    $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''T3, VarT (mkName "k"), VarT (mkName "a"), VarT (mkName "b")]]))+  )+++showT2 = TestCase+  (assertEqual+    "T2 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''T2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++showT3 = TestCase+  (assertEqual+    "T3 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''T3, VarT (mkName "k"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++ordR0 = TestCase+  (assertEqual+    "R0 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''R0,  VarT (mkName "b")]]))+  )++showRx0 = TestCase+  (assertEqual+    "Rx0 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''Rx0, VarT (mkName "c"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++showColonEqColon = TestCase+  (assertEqual+    ":=: is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''(:=:), VarT (mkName "a"), VarT (mkName "b")]]))+  )++showExp = TestCase+  (assertEqual+    "Exp is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''Exp, VarT (mkName "a")]]))+  )++showDataQL = TestCase+  (assertEqual+    "Exp is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''DataQL, VarT (mkName "a")]]))+  )++showP1 = TestCase+  (assertEqual+    "P1 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''P1, VarT (mkName "a")]]))+  )++showT6 = TestCase+  (assertEqual+    "T6 is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''Rx0, VarT (mkName "c"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++showStream = TestCase+  (assertEqual+    "Stream is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''Stream, VarT  (mkName "k"), VarT (mkName "x"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++showD = TestCase+  (assertEqual+    "D is instance of Show"+    True+    $((qBoolToExp $ isInstance' ''Show [apps [ConT ''D, VarT (mkName "b")]]))+  )+++ioIO_ = TestCase+  (assertEqual "IO_ is instance of MonadIO"+               True+               $((qBoolToExp $ isInstance' ''MonadIO [apps [ConT ''IO_]]))+  )++realFloatF32 = TestCase+  (assertEqual "F32 is instance of RealFloat"+               True+               $((qBoolToExp $ isInstance' ''RealFloat [apps [ConT ''F32]]))+  )++ordHsModule = TestCase+  (assertEqual "HsModule is instance of Ord"+               True+               $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''HsModule]]))+  )++ordHsDecl = TestCase+  (assertEqual "HsModule is instance of Ord"+               True+               $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''HsDecl]]))+  )

@@ -0,0 +1,211 @@+{-# LANGUAGE TemplateHaskell, StandaloneDeriving, DeriveGeneric #-}+module Generic where+import           Data.Derive.TopDown.IsInstance+import           GHC.Generics+import           Language.Haskell.TH.Syntax+import           Test.HUnit+import           Types+import           Utils++genericCompany = TestCase+  (assertEqual "Company is instance of Generic"+               True+               $((qBoolToExp $ isInstance' ''Generic [(ConT ''Company)]))+  )++genericE0 = TestCase+  (assertEqual "E0 is instance of Generic"+               True+               $((qBoolToExp $ isInstance' ''Generic [(ConT ''E0)]))+  )++genericI = TestCase+  (assertEqual+    "I is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''I, VarT (mkName "b")]]))+  )++genericB = TestCase+  (assertEqual+    "B is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''B, VarT (mkName "a"), VarT (mkName "b")]]))+  )++genericT = TestCase+  (assertEqual+    "T is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''T, VarT (mkName "a"), VarT (mkName "b"), VarT (mkName "c")]]))+  )++genericT1 = TestCase+  (assertEqual "T1 is instance of Generic"+               True+               $((qBoolToExp $ isInstance' ''Generic [(ConT ''T1)]))+  )++genericT2 = TestCase+  (assertEqual+    "T2 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''T2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++genericT3 = TestCase+  (assertEqual+    "T3 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''T3, VarT (mkName "k"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++genericR0 = TestCase+  (assertEqual+    "R0 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''R0, VarT (mkName "a")]]))+  )++genericR1 = TestCase+  (assertEqual+    "R1 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''R1, VarT (mkName "a")]]))+  )++genericR2 = TestCase+  (assertEqual+    "R2 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''R2, VarT (mkName "a")]]))+  )++genericR6 = TestCase+  (assertEqual+    "R6 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''R6, VarT (mkName "a")]]))+  )++generic1R0 = TestCase+  (assertEqual "R0 is instance of Generic1"+               True+               $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''R0]]))+  )++generic1R1 = TestCase+  (assertEqual "R1 is instance of Generic1"+               True+               $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''R1]]))+  )++generic1R6 = TestCase+  (assertEqual "R6 is instance of Generic1"+               True+               $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''R6]]))+  )++generic1Rx0 = TestCase+  (assertEqual+    "Rx0 is instance of Generic1"+    True+    $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''Rx0, VarT (mkName "a"), VarT (mkName "b")]]))+  )++genericRx1 = TestCase+  (assertEqual+    "Rx1 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''Rx1, VarT (mkName "a"), VarT (mkName "b"), VarT (mkName "c")]]))+  )++genericRx2 = TestCase+  (assertEqual+    "Rx2 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''Rx2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++genericColonEqColon = TestCase+  (assertEqual+    "(:=:) is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''(:=:), VarT (mkName "a"), VarT (mkName "b")]]))+  )++generic1ColonEqColon = TestCase+  (assertEqual+    "(:=:) is instance of Generic1"+    True+    $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''(:=:), VarT (mkName "a") ]]))+  )++genericP1 = TestCase+  (assertEqual+    "P1 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''P1, VarT (mkName "a")]]))+  )++genericT6 = TestCase+  (assertEqual+    "T6 is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''P1, VarT (mkName "a")]]))+  )++genericList = TestCase+  (assertEqual+    "List is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''List, VarT (mkName "a")]]))+  )++generic1List = TestCase+  (assertEqual "List is instance of Generic1"+               True+               $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''List]]))+  )++genericStream = TestCase+  (assertEqual+    "Stream is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''Stream, VarT (mkName "k"), VarT (mkName "a"), VarT (mkName "b"), VarT (mkName "c")]]))+  )++genericP = TestCase+  (assertEqual+    "P is instance of Generic"+    True+    $((qBoolToExp $ isInstance' ''Generic [apps [ConT ''P, VarT (mkName "a"), VarT (mkName "b")]]))+  )++generic1P = TestCase+  (assertEqual+    "P is instance of Generic1"+    True+    $((qBoolToExp $ isInstance' ''Generic1 [apps [ConT ''P, VarT (mkName "a")]]))+  )++functorP = TestCase+  (assertEqual+    "P is instance of Functor"+    True+    $((qBoolToExp $ isInstance' ''Functor [apps [ConT ''P, VarT (mkName "a")]]))+  )++functorE = TestCase+  (assertEqual+    "E is instance of Functor"+    True+    $((qBoolToExp $ isInstance' ''Functor [apps [ConT ''E, VarT (mkName "a")]]))+  )++functorPx = TestCase+  (assertEqual "Px is instance of Functor"+               True+               $((qBoolToExp $ isInstance' ''Functor [apps [ConT ''Px]]))+  )+

@@ -0,0 +1,99 @@+{-# LANGUAGE TemplateHaskell #-}+module Instance where++import           Data.Binary+import           Data.Derive.TopDown.IsInstance+import           Language.Haskell.Syntax+import           Language.Haskell.TH.Syntax+import           Test.HUnit+import           Types+import           Utils++binaryCompany = TestCase+  (assertEqual "Company is instance of Binary"+               True+               $((qBoolToExp $ isInstance' ''Binary [(ConT ''Company)]))+  )++binaryI = TestCase+  (assertEqual+    "I is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''I, VarT (mkName "a")]]))+  )++binaryB = TestCase+  (assertEqual+    "N is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary [apps [(ConT ''B), VarT (mkName "a"), VarT (mkName "b")]]))+  )++binaryT = TestCase+  (assertEqual+    "T is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary [apps [(ConT ''T), VarT (mkName "a"), VarT (mkName "b"), VarT (mkName "c")]]))+  )++binaryT1 = TestCase+  (assertEqual "T1 is instance of Binary"+               True+               $((qBoolToExp $ isInstance' ''Binary  [ConT ''T1]))+  )++binaryT2 = TestCase+  (assertEqual+    "T2 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''T2, VarT (mkName "a"), VarT (mkName "b")]]))+  )++binaryT3 = TestCase+  (assertEqual+    "T3 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''T3, VarT (mkName "k"), VarT (mkName "a"), VarT (mkName "b")]]))+  )++binaryR0 = TestCase+  (assertEqual+    "R0 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''R0, VarT (mkName "a")]]))+  )++binaryR6 = TestCase+  (assertEqual+    "R6 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''R6, VarT (mkName "a")]]))+  )++binaryRx0 = TestCase+  (assertEqual+    "Rx0 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''Rx0, VarT (mkName "a"), VarT (mkName "b"), VarT (mkName "c")]]))+  )++binaryRx3 = TestCase+  (assertEqual+    "Rx3 is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''Rx3, VarT (mkName "a"), VarT (mkName "b")]]))+  )++binaryE = TestCase+  (assertEqual+    "E is instance of Binary"+    True+    $((qBoolToExp $ isInstance' ''Binary  [apps [ConT ''E, VarT (mkName "a"), VarT (mkName "b")]]))+  )++binaryHsModule = TestCase+  (assertEqual "HsModule is instance of Binary"+               True+               $((qBoolToExp $ isInstance' ''Binary  [ConT ''HsModule]))+  )+

@@ -0,0 +1,121 @@+module Main where++import           Control.Monad+import           Derive+import           Generic+import           Instance+import           Template+import           Test.HUnit++derive = TestList+  [ eqPerson+  , ordPerson+  , showCompany+  , eqE0+  , ordE0+  , showE0+  , eqT1+  , ordT1+  , showT1+  , eqT2+  , ordT2+  , ordT3+  , showT2+  , showT3+  , ordR0+  , showRx0+  , showColonEqColon+  , showExp+  , showDataQL+  , showP1+  , showT6+  , showStream+  , showD+  , ioIO_+  , realFloatF32+  , ordHsModule+  , ordHsDecl+  ]++generic = TestList+  [ genericCompany+  , genericE0+  , genericI+  , genericB+  , genericT+  , genericT1+  , genericT2+  , genericT3+  , genericR0+  , genericR1+  , genericR2+  , genericR6+  , generic1R0+  , generic1R1+  , generic1R6+  , generic1Rx0+  , genericRx1+  , genericRx2+  , genericColonEqColon+  , generic1ColonEqColon+  , genericP1+  , genericT6+  , genericList+  , generic1List+  , genericStream+  , genericP+  , generic1P+  , functorP+  , functorE+  , functorPx+  ]++instances = TestList+  [ binaryCompany+  , binaryI+  , binaryB+  , binaryT+  , binaryT1+  , binaryT2+  , binaryT3+  , binaryR0+  , binaryR6+  , binaryRx0+  , binaryRx3+  , binaryE+  , binaryHsModule+  ]++templates = TestList+  [ arityCompany+  , arityI+  , arityB+  , arityT+  , arityT1+  , arityT2+  , arityT3+  , arityR0+  , arityR6+  , arityRx0+  , arityRx3+  , arityT4+  , arityColonEqColon+  , arityT5+  , arityExp+  , arityP1+  , arityP2+  , arityList+  , arityStream+  , arityC+  , arityD+  , arityIO_+  , arityF32+  , arityHsModule+  , arityHsDecl+  ]+main :: IO ()+main = do+  void $ runTestTT derive+  void $ runTestTT generic+  void $ runTestTT instances+  void $ runTestTT templates

@@ -0,0 +1,164 @@+{-# LANGUAGE TemplateHaskell #-}+module Template where+import           Arity+import           Data.Derive.TopDown.IsInstance+import           Language.Haskell.Syntax+import           Language.Haskell.TH.Syntax+                                         hiding ( Exp )+import           Test.HUnit+import           Types+import           Utils++arityCompany = TestCase+  (assertEqual+    "Company is instance of Arity"+    True+    $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Company]]))+  )++arityI = TestCase+  (assertEqual "I is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''I]]))+  )++arityB = TestCase+  (assertEqual "B is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''B]]))+  )++arityT = TestCase+  (assertEqual "T is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T]]))+  )++arityT1 = TestCase+  (assertEqual "T1 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T1]]))+  )++arityT2 = TestCase+  (assertEqual "T2 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T2]]))+  )++arityT3 = TestCase+  (assertEqual "T3 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T3]]))+  )++arityR0 = TestCase+  (assertEqual "T0 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''R0]]))+  )++arityR6 = TestCase+  (assertEqual "R6 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''R6]]))+  )++arityRx0 = TestCase+  (assertEqual "Rx0 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Rx0]]))+  )++arityRx3 = TestCase+  (assertEqual "Rx6 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Rx3]]))+  )++arityT4 = TestCase+  (assertEqual "T4 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T4]]))+  )++arityColonEqColon = TestCase+  (assertEqual ":=: is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''(:=:)]]))+  )++arityT5 = TestCase+  (assertEqual "T5 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''T5]]))+  )++arityExp = TestCase+  (assertEqual "Exp is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Exp]]))+  )++arityP1 = TestCase+  (assertEqual "P1 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''P1]]))+  )++arityP2 = TestCase+  (assertEqual "P2 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''P2]]))+  )++arityList = TestCase+  (assertEqual "List is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''List]]))+  )++arityStream = TestCase+  (assertEqual+    "Stream is instance of Arity"+    True+    $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Stream]]))+  )++arityC = TestCase+  (assertEqual "C is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''C]]))+  )++arityD = TestCase+  (assertEqual "D is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''D]]))+  )++arityIO_ = TestCase+  (assertEqual "IO_ is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''IO_]]))+  )++arityF32 = TestCase+  (assertEqual "F32 is instance of Arity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''F32]]))+  )++arityHsModule = TestCase+  (assertEqual+    "HsModule is instance of Arity"+    True+    $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''HsModule]]))+  )++arityHsDecl = TestCase+  (assertEqual+    "HsDecl is instance of Arity"+    True+    $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''HsDecl]]))+  )

@@ -0,0 +1,288 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE StarIsType #-}   +#endif+{-# LANGUAGE DeriveGeneric #-}            +{-# LANGUAGE GeneralizedNewtypeDeriving #-}            +{-# LANGUAGE DerivingStrategies #-}            +{-# LANGUAGE DeriveFunctor #-}            +{-# LANGUAGE RankNTypes #-}            +{-# LANGUAGE StandaloneDeriving #-}            +{-# LANGUAGE DataKinds #-}            +{-# LANGUAGE TypeOperators #-}            +{-# LANGUAGE GADTs #-}            +{-# LANGUAGE KindSignatures #-}            +{-# LANGUAGE TypeFamilies #-}            +{-# LANGUAGE FlexibleContexts #-}            +{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}++++module Types where+import           Arity+import           Control.Monad.IO.Class+import           Data.Binary+import           Data.Derive.Superclass+import           Data.Derive.TopDown+import           Data.Proxy+import           Data.Ratio+import           GHC.Generics            hiding ( C+                                                , D+                                                )+import           Language.Haskell.Syntax+-- types for testing++-- ^ simple cases+type Age = Int+data Person = Person+  { pname :: String+  , age   :: Age+  }+data Department = Department+  { head   :: Person+  , staffs :: [Person]+  }+data Company = Company+  { manager     :: Person+  , departments :: [Department]+  }++$(deriving_superclasses ''Ord ''Person)+$(deriving_ ''Show ''Company)+$(deriving_ ''Generic ''Company)+$(instance_ ''Binary ''Company)+$(deriving_th_with (''TypeArity, makeTypeArity) ''Company [int, char])++-- for enumeration+data E0 = E01 | E02 | E03 | E04++$(deriving_superclasses ''Ord ''E0)+$(deriving_ ''Show ''E0)+$(deriving_ ''Generic ''E0)+$(deriving_th (''TypeArity, makeTypeArity) ''E0)+data I a = I a+data B a b = B a b+data T a b c = T a b c++$(deriving_superclasses ''Ord ''I)+$(deriving_superclasses ''Ord ''B)+$(deriving_superclasses ''Ord ''T)++$(deriving_ ''Show ''I)+$(deriving_ ''Show ''B)+$(deriving_ ''Show ''T)++$(deriving_ ''Generic ''I)+$(deriving_ ''Generic ''B)+$(deriving_ ''Generic ''T)++$(instance_ ''Binary ''I)+$(instance_ ''Binary ''B)+$(instance_ ''Binary ''T)++$(deriving_th (''TypeArity, makeTypeArity) ''I)+$(deriving_th (''TypeArity, makeTypeArity) ''B)+$(deriving_th (''TypeArity, makeTypeArity) ''T)++-- regular constructor+data T1 = T11 Int Bool Char+        | T12 String+        | T13 [Int]+        | T14 (Int, Bool, Char)++$(deriving_superclasses ''Ord ''T1)+$(deriving_ ''Show ''T1)+$(deriving_ ''Generic ''T1)+$(instance_ ''Binary ''T1)+$(deriving_th (''TypeArity, makeTypeArity) ''T1)++data T2 a b = T21 a [b]+            | T22 b (Bool) (Either a b)+            | T23 Int ((a, b)) (Maybe a)+            | T24 (T3 Maybe a b)+++data T3 (k :: * -> *) (a :: *) b = T31 (k a) [b]+                                 | T32 b Bool (a) (Maybe a)+                                 | T33 Int (a, k b)+                                 | T34 (T2 a b)+-- 2 mutual recursive declaration+$(deriving_ ''Show ''T2)+$(deriving_ ''Show ''T3)++-- $(deriving_superclasses ''Ord ''T2)+-- $(deriving_superclasses ''Ord ''T3)+fmap concat (sequence [(deriving_superclasses ''Ord ''T2), (deriving_superclasses ''Ord ''T3)])+$(deriving_ ''Generic ''T2)+$(deriving_ ''Generic ''T3)+$(instance_ ''Binary ''T2)+$(instance_ ''Binary ''T3)++$(deriving_th (''TypeArity, makeTypeArity) ''T2)++-- mutual recursive declaration tests+data R0 a = R01 (R1 a)+data R1 x = R11 (R2 x) x+data R2 f = R21 (R3 f)+data R3 v = R31 (R4 v)+data R4 v = R41 (R5 v)+data R5 b = R51 (R6 b)+data R6 b = R61 (R1 b)+$(deriving_ ''Show ''R0)+$(deriving_ ''Generic ''R0)+$(deriving_ ''Generic1 ''R0)+$(instance_ ''Binary ''R0)+$(deriving_th (''TypeArity, makeTypeArity) ''R0)++data Rx0 a b c = Rx01 a (Rx1 Int a c) (Rx2 b c)+data Rx1 x y z = Rx11 z (Rx2 z x) | Rx12 (Rx0 Bool Char y)+data Rx2 f g = Rx21 (Rx3 Int g) (Rx1 f g f)+data Rx3 v b = Rx31 v | Rx32 (Rx1 Int Char b) b+$(deriving_th (''TypeArity, makeTypeArity) ''Rx0)++$(deriving_ ''Show ''Rx0)+$(deriving_ ''Generic ''Rx0)+$(deriving_with ''Generic1 ''Rx0 Nothing [''Rx1, ''Rx2] genInferredContext)+$(deriving_with ''Generic1 ''Rx3 Nothing [''Rx1] genInferredContext)+$(instance_ ''Binary ''Rx0)+++-- forall type+-- deriving for this is unsupported by GHC+data T4 a = T41 (forall b . Show b => Either a b)+$(deriving_th_with (''TypeArity, makeTypeArity) ''T4 [''Either])++-- Type Operator+data (:=:) a b = E11 a b | E12 (a,b) | E13 [b] Int+$(deriving_ ''Show ''(:=:))+$(deriving_ ''Generic ''(:=:))+++data T5 a b = T5 (a :=: b)++$(deriving_ ''Show ''T5)+$(deriving_ ''Generic ''T5)+$(deriving_ ''Generic1 ''T5)+$(deriving_th (''TypeArity, makeTypeArity) ''T5)+-- data type record++-- GADTs+data Exp a where+    Add :: Int  -> Int -> Exp Int+    And :: Bool -> Bool -> Exp Bool+    Le  :: Int  -> Int -> Exp Bool++$(deriving_ ''Show ''Exp)+$(deriving_th (''TypeArity, makeTypeArity) ''Exp)++-- Cannot derive Generic for GADT+-- must be a vanilla data constructor to derive+-- $(deriving_ ''Generic ''Exp)++data Aggregator = SUM | AVG | MIN | MAX | CNT | CNTD | ATTR++data Granularity = G0 | G1++data DataQL a where+  DimRaw :: String -> DataQL G0+  MsrRaw :: String -> DataQL G0+  Agg :: Aggregator -> DataQL G0 -> DataQL G1+  Include :: [DataQL G0] -> DataQL G1 -> DataQL G0+  Exclude :: [DataQL G0] -> DataQL G1 -> DataQL G0+  Fixed   :: [DataQL G0] -> DataQL G1 -> DataQL G0++$(deriving_ ''Show ''DataQL)+$(deriving_th (''TypeArity, makeTypeArity) ''DataQL)+-- TODO: Record GADTs++-- ^ phantom+-- TODO: test a is not in the context+data P1 a = P1C1 (P2 a)+data P2 b = P2C1 Int++$(deriving_ ''Show ''P1)+$(deriving_ ''Generic ''P1)+$(deriving_th (''TypeArity, makeTypeArity) ''P1)++-- ^ type family+type family F a b++type instance F Int Char = Bool+type instance F String Char = String+type instance F a Int = Maybe a++type family G x++-- TODO: test G b is not in the context+data T6 a b c = T61 (Maybe (F a c)) a (Proxy (G b))+$(deriving_ ''Show ''T6)+$(deriving_ ''Generic ''T6)+-- TODO: template instance generation need to handle type family+-- $(deriving_th (''TypeArity, makeTypeArity) ''T6)++-- ^ recursive definition+data List a = Nil | Cons a (List a)+$(deriving_ ''Show ''List)+$(deriving_ ''Generic ''List)+$(deriving_ ''Generic1 ''List)+$(deriving_th (''TypeArity, makeTypeArity) ''List)++-- ^ recursive defintion+data Stream k a b c = S (k a) | S2 a (Stream k b c Int)+    -- deriving Eq+{-+deriving Eq in GHC for Stream will not put (k Int) in the context+-}+-- context is (k b),(k b), a, b, c should be +$(deriving_ ''Show ''Stream)+$(deriving_ ''Generic ''Stream)+$(deriving_th (''TypeArity, makeTypeArity) ''Stream)++-- ^ composite +-- TODO: test b is not in context+data P a b = P (E a (Px b))+data E x y = L x | R y+data Px z = Px+$(deriving_ ''Show ''P)+$(deriving_ ''Generic ''P)+$(deriving_ ''Functor ''P)+$(deriving_ ''Generic1 ''P)+$(deriving_th (''TypeArity, makeTypeArity) ''P)+#if __GLASGOW_HASKELL__ >= 804+$(deriving_with ''Binary ''E Nothing [] genHoleContext)+#else+$(deriving_with ''Binary ''E Nothing [] genInferredContext)+#endif++-- $(instance_with ''Binary ''E  [] Nothing genHoleContext)+-- GHC deriving does not work on ForallT +data C b = C (forall a. Show a => a) b | C2 Int b (Maybe Bool)++-- C must not have exotic unlifted or polymorphic argument+-- $(deriving_ ''Generic ''C)+$(deriving_th (''TypeArity, makeTypeArity) ''C)++-- ^ ForallC+data D a = forall b. Show b => D b | D2 a+$(deriving_ ''Show ''D)+$(deriving_th (''TypeArity, makeTypeArity) ''D)++-- ^ for superclass MonadIO +newtype IO_ a = IO_ (IO a)+$(strategy_deriving_superclasses NewtypeStrategy ''MonadIO ''IO_)+$(deriving_th (''TypeArity, makeTypeArity) ''IO_)++-- ^ for superclass RealFloat+newtype F32 = F32 Float+$(strategy_deriving_superclasses NewtypeStrategy ''RealFloat ''F32)+$(deriving_th (''TypeArity, makeTypeArity) ''F32)++-- deriving GHC syntax tree in haskell-src+$(deriving_ ''Ord ''HsModule)+$(deriving_with ''Generic ''HsModule Nothing [''Ratio] genInferredContext)+$(instance_ ''Binary ''HsModule)+$(deriving_th (''TypeArity, makeTypeArity) ''HsModule)

@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module Utils where++import           Language.Haskell.TH++qBoolToExp :: Q Bool -> Q Exp+qBoolToExp q = do+  b <- q+  if b then [e|True|] else [e|False|]++apps :: [Type] -> Type+apps ts = foldl1 AppT ts