derive-topdown 0.1.1.0 → 0.1.1.1

raw patch · 15 files changed

+420/−185 lines, 15 filesdep +haskell-src-extsPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: haskell-src-exts

API changes (from Hackage documentation)

Files

• README.md +2/−2
• derive-topdown.cabal +6/−3
• src/Data/Derive/Superclass.hs +3/−2
• src/Data/Derive/TopDown/CxtGen.hs +34/−28
• src/Data/Derive/TopDown/Instance.hs +46/−49
• src/Data/Derive/TopDown/InstanceDecGen.hs +80/−0
• src/Data/Derive/TopDown/Lib.hs +19/−17
• src/Data/Derive/TopDown/Standalone.hs +92/−69
• src/Data/Derive/TopDown/StandaloneDecGen.hs +97/−0
• src/Data/Derive/TopDown/TH.hs +1/−1
• test/Derive.hs +18/−0
• test/GhcAst.hs +7/−5
• test/GhcTest.hs +2/−2
• test/Spec.hs +3/−0
• test/Types.hs +10/−7

@@ -62,9 +62,9 @@ instance Binary a_af4Y => Binary (Company a_af4Y) ``` ## 3. Usage with Template Haskell-For generating instances with a template Haskell function, `deriving_th`, `deriving_ths` and `deriving_thss` can be used:+For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used: ```haskell-deriving_ths+derivingTHs     [(''ToJSON, deriveToJSON defaultOptions),     (''FromJSON, deriveFromJSON defaultOptions)]     ''Company

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           derive-topdown-version:        0.1.1.0+version:        0.1.1.1 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@@ -18,7 +18,7 @@ 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+    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 , GHC == 9.12.2 , GHC == 9.14.1 extra-source-files:     README.md     CHANGELOG.md@@ -40,6 +40,8 @@       Data.Derive.TopDown   other-modules:       Data.Derive.TopDown.Lib+      Data.Derive.TopDown.StandaloneDecGen+      Data.Derive.TopDown.InstanceDecGen   hs-source-dirs:       src   default-extensions:@@ -83,6 +85,7 @@     , derive-topdown     , ghc     , haskell-src+    , haskell-src-exts     , mtl     , primitive     , syb

@@ -28,6 +28,7 @@                                                 , nub                                                 ) import           Language.Haskell.TH+import           Debug.Trace                    (traceM)    -- Only support class that has paramter with kind * or * -> * deriving_superclasses'@@ -63,9 +64,9 @@               ConT className -> do                 superclass_decls <- deriving_superclasses' st className tn                 return superclass_decls-              x -> error $ "cannot generate class for " ++ show x+              x -> traceM ("cannot generate class for " ++ show x) >> error ""           return $ topClassInstance ++ ss-        _ -> error $ show cn ++ "is not type class"+        _ -> traceM (show cn ++ "is not type class") >> error ""  {- | Note: It cannot be used with mutual recursive types. 

@@ -50,6 +50,7 @@ import           Data.Set                       ( Set ) import           GHC.Generics import           Language.Haskell.TH+import           Debug.Trace  data Env = Env   { inferring    :: [Name]             -- ^ encountered types during infer process@@ -131,34 +132,34 @@   SigT     ty _  -> doesFieldContainPotentialContext ty   VarT      _    -> return True   ConT      _    -> return False-  PromotedT _    -> error "impossible field for PromotedT"+  PromotedT _    -> traceM "impossible field for PromotedT" >> error ""   InfixT t1 _ t2 -> liftA2 (||)                            (doesFieldContainPotentialContext t1)                            (doesFieldContainPotentialContext t2)-  UInfixT         _ _ _ -> error "impossible field for UInfixT"+  UInfixT         _ _ _ -> traceM "impossible field for UInfixT" >> error "" #if __GLASGOW_HASKELL__ >= 904-  PromotedInfixT  _ _ _ -> error "impossible field for PromotedInfixT"-  PromotedUInfixT _ _ _ -> error "impossible field for PromotedUInfixT"+  PromotedInfixT  _ _ _ -> traceM "impossible field for PromotedInfixT" >> error ""+  PromotedUInfixT _ _ _ -> traceM "impossible field for PromotedUInfixT" >> error "" #endif   ParensT       ty      -> doesFieldContainPotentialContext ty-  TupleT        _       -> error "impossible field for TupleT"-  UnboxedTupleT _       -> error "impossible field for UnboxedTupleT"-  UnboxedSumT   _       -> error "impossible field for UnboxedSumT"+  TupleT        _       -> traceM "impossible field for TupleT" >> error ""+  UnboxedTupleT _       -> traceM "impossible field for UnboxedTupleT" >> error ""+  UnboxedSumT   _       -> traceM "impossible field for UnboxedSumT" >> error ""   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"+  EqualityT             -> traceM "impossible field for EqualityT" >> error ""+  ListT                 -> traceM "impossible field for ListT" >> error ""+  PromotedTupleT _      -> traceM "impossible field for PromotedTupleT" >> error ""+  PromotedNilT          -> traceM "impossible field for PromotedNilT" >> error ""+  PromotedConsT         -> traceM "impossible field for PromotedConsT" >> error ""+  StarT                 -> traceM "impossible field for StarT" >> error ""+  ConstraintT           -> traceM "impossible field for ConstraintT" >> error ""+  LitT _                -> traceM "impossible field for LitT" >> error ""+  WildCardT             -> traceM "impossible field for WildCardT" >> error "" #if __GLASGOW_HASKELL__ >= 808-  ImplicitParamT _ _    -> error "impossible field for ImplicitParamT"+  ImplicitParamT _ _    -> traceM "impossible field for ImplicitParamT" >> error "" #endif  -- | a lazily applied type paramters lookup function@@ -221,14 +222,19 @@           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+apply_until_fix_point tn = go []+ where+  go seen = do+    env <- get+    let tn_fields = fields env ! tn+    if tn_fields `elem` seen+      then return ()+      else do+        gen_subst tn+        subst_data_newtype tn+        env' <- get+        let tn_fields' = fields env' ! tn+        if tn_fields == tn_fields' then return () else go (tn_fields : seen)  -- put fields of data or newtype fields into map gen_subst :: Name -> CIM ()@@ -273,12 +279,12 @@             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+    err_t -> traceM $ "gen_subst does not support type: " ++ show err_t >> error ""  subst_data_newtype :: Name -> CIM () subst_data_newtype tn = do   env <- get-  let tn_substs = M.toList $ substitution env ! tn+  let tn_substs = M.toList $ M.findWithDefault M.empty tn (substitution env)   forM_ tn_substs $ \(t, t2t) -> case getLeftMostType t of     ConT ctn -> do       e <- get@@ -307,7 +313,7 @@             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+      traceM $ "subst_data_newtype does not support type: " ++ show err_ty >> error ""  genInferredContext :: ClassName -> TypeName -> Q Cxt genInferredContext cn tn = if cn == ''Generic

@@ -16,65 +16,25 @@   , instances   , instancess   , instance_with+  , instance_debug+  , instance_with_breaks_debug+  , instances_debug+  , instancess_debug+  , instance_with_debug   ) 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.Derive.TopDown.Types-import           Data.List                      ( foldl1' )+import           Data.Derive.TopDown.InstanceDecGen import           Language.Haskell.TH -gen_instance_decl-  :: ClassName-  -> TypeName-  -> [TypeName]  -- ^ a list of types that breaks the generation process-  -> Maybe Overlap-  -> ContextGenerator -- ^ 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) []+  evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext False) []  instance_with_breaks   :: Name -- ^ class name@@ -82,7 +42,7 @@   -> [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) []+  evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext False) []  instances   :: [Name] -- ^ class names@@ -103,4 +63,41 @@   -> Maybe Overlap   -> ContextGenerator -- ^ a context generator   -> Q [Dec]-instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg) []+instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg False) []+++instance_debug+  :: Name -- ^ class name+  -> Name -- ^ type name+  -> Q [Dec]+instance_debug cn tn =+  evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext True) []++instance_with_breaks_debug+  :: Name -- ^ class name+  -> Name -- ^ type name+  -> [Name] -- ^ type names that stop the deriving process+  -> Q [Dec]+instance_with_breaks_debug cn tn bs =+  evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext True) []++instances_debug+  :: [Name] -- ^ class names+  -> Name   -- ^ type name+  -> Q [Dec]+instances_debug cns tn = fmap concat (mapM (\x -> instance_ x tn) cns)++instancess_debug+  :: [Name] -- ^ class names+  -> [Name] -- ^ type names+  -> Q [Dec]+instancess_debug cns tns = fmap concat (mapM (\x -> instances cns x) tns)++instance_with_debug+  :: ClassName+  -> TypeName+  -> [TypeName]        -- ^ a list of types that breaks the generation process+  -> Maybe Overlap+  -> ContextGenerator -- ^ a context generator+  -> Q [Dec]+instance_with_debug cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg True) []

@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.InstanceDecGen+-- 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.InstanceDecGen (+    gen_instance_decl+) where++import           Control.Monad+import           Control.Monad.State+import           Data.Derive.TopDown.IsInstance+import           Data.Derive.TopDown.Lib+import           Data.Derive.TopDown.Types+import           Data.List                      ( foldl1' )+import           Data.Primitive.Types+import           Language.Haskell.TH+import           Debug.Trace++gen_instance_decl+  :: ClassName+  -> TypeName+  -> [TypeName]  -- ^ a list of types that breaks the generation process+  -> Maybe Overlap+  -> ContextGenerator -- ^ a context generator+  -> Bool             -- ^ is debug+  -> StateT [Type] Q [Dec]+gen_instance_decl cn tn breaks mo cg debug = do+  when debug $ do+    traceM $ "standalone_deriving_decl: `" +            ++ show tn ++ "\' for class `"  ++ show cn ++ "\'"+  (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]+      when debug $ do+        traceM $ "standalone_deriving_decl: `" ++ show tn +                ++ "\' is instance of `" ++ show cn ++ "\':"+                ++ show isMember+      table    <- get+      isPrimitive <-lift $ isInstance' ''Prim [saturatedType]+      if isMember || elem instanceType table || elem tn breaks || isPrimitive+         -- 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+          when debug $ do+            traceM $ "standalone_deriving_decl: `"+                        ++ show tn ++ "\' context is " +                        ++ pprint classContext+          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 debug) names'+          return $ concat xs ++ decl

@@ -38,7 +38,7 @@     DatatypeInfo(..),     reifyDatatype     )-+import Debug.Trace (trace, traceM) noWarnExpandSynsWith :: Type -> Q Type noWarnExpandSynsWith = expandSynsWith noWarnTypeFamilies @@ -60,7 +60,7 @@                                     then t                                     else x substitute (VarT _, _) x = x-substitute (t, _) x = error $ "cannot substitute " ++ show t ++ " with " ++ show x+substitute (t, _) x = trace ("cannot substitute " ++ show t ++ " with " ++ show x) (error "")  substituteVar :: (Type, Type) -> Type -> Type substituteVar s = everywhere (mkT (substitute s))@@ -173,8 +173,8 @@                               if k == StarT                                 then return False                                 else return True-                  _ -> error $ "Cannot reify kind of class " ++ show cn-        _ -> error $ show cn ++ " is not a class"+                  _ -> traceM ("Cannot reify kind of class " ++ show cn) >> error ""+        _ -> traceM (show cn ++ " is not a class") >> error ""  getGadtCon :: Con -> [Con] getGadtCon g@(GadtC _ _ _) = [g]@@ -202,8 +202,8 @@ 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"+getAllConFields (GadtC    _ _ _  ) = trace "Should not use this to get fields of GADT" (error "")+getAllConFields (RecGadtC _ _ _  ) = trace "Should not use this to get fields of GADT" (error "")  {-| data T a1 a2 = Con1 a1 | Con2 a2 ...  return [a1, a2], [Con1 a1, Con2 a2]@@ -220,12 +220,13 @@                 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."+                  TySynD   _ _ _        -> traceM (show name ++ " is a type synonym and `TypeSynonymInstances' is not supported."+                      ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package.") +                      >> (error "")                   x -> do-                      error $ pprint (x :: Dec) ++ " is not a data or newtype definition."+                      traceM (pprint (x :: Dec) ++ " is not a data or newtype definition.") >> error ""               PrimTyConI _ _ _ -> return ([], [])-              x -> error $ show x ++ " is not supported"+              x -> traceM (show x ++ " is not supported") >> error ""  #if __GLASGOW_HASKELL__ >= 900 getTyVarFields :: TypeName -> Q ([TyVarBndr ()], [Type])@@ -249,11 +250,12 @@                       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."+                  TySynD   _ _ _        -> traceM (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.")+                      >> error ""                   x -> do-                      error $ pprint (x :: Dec) ++ " is not a data or newtype definition."-              _ -> error $ "Cannot generate instances for " ++ show name+                      traceM (pprint (x :: Dec) ++ " is not a data or newtype definition.") >> error ""+              _ -> traceM ("Cannot generate instances for " ++ show name) >> error ""  getTypeConstructor :: Type -> Type getTypeConstructor (AppT a1 _) = getTypeConstructor a1@@ -265,7 +267,7 @@                 case info of                   TyConI (DataD _ _ tvb _ _ _)    -> return $ map getTVBName tvb                   TyConI (NewtypeD _ _ tvb _ _ _) -> return $ map getTVBName tvb-                  _                             -> error "impossible case in reifyTypeParameters"+                  _                             -> traceM "impossible case in reifyTypeParameters" >> error ""                data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Show, Enum, Eq) @@ -277,9 +279,9 @@               DataD _ _ _ _ _ _   -> return Data               NewtypeD _ _ _ _ _ _ -> return Newtype               TySynD _ _ _ -> return TypeSyn-              _ -> error $ "not a type declaration: " ++ show name+              _ -> traceM ("not a type declaration: " ++ show name) >> (error "")            PrimTyConI _ _ _ -> return BuiltIn-           _ ->  error $ "not a type declaration: " ++ show name +           _ ->  traceM ("not a type declaration: " ++ show name ) >> (error "")   getTypeNames :: Type -> [Name]

@@ -18,88 +18,32 @@    , derivings    , derivingss    , deriving_with+   , deriving_debug+   , deriving_with_breaks_debug+   , derivings_debug+   , derivingss_debug+   , deriving_with_debug #if __GLASGOW_HASKELL__ >= 802    , strategy_deriving    , strategy_derivings    , strategy_derivingss+   , strategy_deriving_debug+   , strategy_derivings_debug+   , strategy_derivingss_debug #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.Derive.TopDown.Types-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-                          -> ContextGenerator -- ^ 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+import Data.Derive.TopDown.StandaloneDecGen  deriving_ :: Name -- ^ class name           -> Name -- ^ type name           -> Q [Dec]-deriving_ cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext) []+deriving_ cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext False) []  {- | This is particularly useful with 'Generic' class. @@ -115,7 +59,7 @@           -> 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) []+deriving_with_breaks cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext False) []  derivings :: [Name] -- ^ class names           -> Name   -- ^ type name@@ -134,7 +78,7 @@                   -> Name                   -> Q [Dec] -strategy_deriving st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext) []+strategy_deriving st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext False) []  strategy_derivings :: DerivStrategy                    -> [Name]@@ -171,4 +115,83 @@               -> [TypeName]        -- ^ a list of types that breaks the generation process               -> ContextGenerator -- ^ 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) []+deriving_with cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg False) []++++deriving_debug :: Name -- ^ class name+          -> Name -- ^ type name+          -> Q [Dec]+deriving_debug cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext True) []++{- | 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 is 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_debug :: Name -- ^ class name+          -> Name -- ^ type name+          -> [Name] -- ^ type names that stop the deriving process+          -> Q [Dec]+deriving_with_breaks_debug cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext True) []++derivings_debug :: [Name] -- ^ class names+          -> Name   -- ^ type name+          -> Q [Dec]+derivings_debug cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns)++derivingss_debug :: [Name] -- ^ class names+           -> [Name] -- ^ type names+           -> Q [Dec]+derivingss_debug cns tns = fmap concat (mapM (\x -> derivings cns x) tns)+++#if __GLASGOW_HASKELL__ >= 802+strategy_deriving_debug :: DerivStrategy+                  -> Name+                  -> Name+                  -> Q [Dec]++strategy_deriving_debug st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext True) []++strategy_derivings_debug :: DerivStrategy+                   -> [Name]+                   -> Name+                   -> Q [Dec]++strategy_derivings_debug st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns)++strategy_derivingss_debug :: DerivStrategy+                    -> [Name]+                    -> [Name]+                    -> Q [Dec]+strategy_derivingss_debug st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns)+#endif++{-| Context generator be the following 3 functions++ 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_debug :: ClassName+              -> TypeName+              -> Maybe DerivStrategy -- ^ deriving strategy+              -> [TypeName]        -- ^ a list of types that breaks the generation process+              -> ContextGenerator -- ^ a context generator,  @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@+              -> Q [Dec]+deriving_with_debug cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg True) []

@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Derive.TopDown.DecGen+-- 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.StandaloneDecGen (+    gen_standalone_deriving_decl+)+where++import Data.Derive.TopDown.Lib+import Language.Haskell.TH+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State+import Data.Derive.TopDown.IsInstance+import Data.Derive.TopDown.Types+import Data.List (foldl1')+import Data.Primitive.Types+import GHC.Generics+import Debug.Trace++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++type Debug = Bool++gen_standalone_deriving_decl :: ClassName+                             -> TypeName+                             -> Maybe DerivStrategy  +                             -> [TypeName]  -- ^ a list of types that breaks the generation process+                             -> ContextGenerator -- ^ a context generator+                             -> Debug+                             -> StateT [Type] Q [Dec]+gen_standalone_deriving_decl cn tn st breaks cg debug = do+                       when debug $ do+                           traceM $ "standalone_deriving_decl: `" +                              ++ show tn ++ "\' for class `"  ++ show cn ++ "\'"+                       (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]+                           when debug $ do+                              traceM $ "standalone_deriving_decl: `" ++ show tn +                                       ++ "\' is instance of `" ++ show cn ++ "\':"+                                       ++ show isMember+                           isPrimitive <-lift $ isInstance' ''Prim [saturatedType]+                           let isGeneric = ''Generic == cn+                           let isGeneric1 = ''Generic1 == cn+                           table <- get+                           if isMember || elem instanceType table || elem tn breaks ||+                              isPrimitive || (tn == ''Integer && (isGeneric || isGeneric1))+                              then return []+                              else do+                                 classContext <- if isCnHighOrderClass +                                                   then return []+                                                   else lift $ cg  cn tn+                                 when debug $ do+                                    traceM $ "standalone_deriving_decl: `"+                                             ++ show tn ++ "\' context is " +                                             ++ pprint classContext+                                 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 debug) names'+                                 return $ concat xs ++ decl

@@ -54,7 +54,7 @@       return $ concat decls ++ decl  deriving_th-  :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding instance generation function+  :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function   -> Name -- ^ type name   -> Q [Dec] deriving_th cd tname = evalStateT (genTH cd tname []) []

@@ -6,10 +6,16 @@ import           Data.Derive.TopDown.IsInstance import           Language.Haskell.TH     hiding ( Exp ) import           Test.HUnit+import           Arity import           Types import           Utils import qualified "haskell-src"  Language.Haskell.Syntax as H+import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hs+import GHC.Core.Opt.Arity (typeArity)+import Test.HUnit (Test(TestCase))+import qualified Language.Haskell.Exts as Hs + eqPerson = TestCase   (assertEqual "Person is instance of Eq"                True@@ -186,4 +192,16 @@   (assertEqual "HsModule is instance of Ord"                True                $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''H.HsDecl]]))+  )++typeArityHsModule = TestCase+  (assertEqual "type arity of HsModule is 1"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Hs.ModuleHead]]))+  )++typeArityHsName = TestCase+  (assertEqual "HsName is instance of TypeArity"+               True+               $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Hs.Name]]))   )

@@ -8,10 +8,11 @@ {-# LANGUAGE DeriveGeneric #-}  module GhcAst where++#if __GLASGOW_HASKELL__ >= 906 import qualified Data.Maybe as Maybe-import qualified "ghc" Language.Haskell.Syntax as G import           Data.Derive.TopDown-#if __GLASGOW_HASKELL__ >= 906+import qualified "ghc" Language.Haskell.Syntax as G import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp import GHC.Types.SrcLoc@@ -19,14 +20,16 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Type import GHC.Types.Var+#if __GLASGOW_HASKELL__ <= 908 import Language.Haskell.Syntax.Concrete+#endif import GHC.Data.FastString import Language.Haskell.Syntax.Expr import GHC.Types.Name.Reader import GHC.Unit.Types import GHC.Types.Name import GHC.Core.TyCo.Rep-import qualified GHC.Core.TyCon as GCT+import GHC.Core.TyCon  import GHC.Types.Unique import Language.Haskell.Syntax.Basic import GHC.Types.ForeignCall@@ -52,13 +55,12 @@ import GHC.ForeignPtr import Data.ByteString.Internal - $(deriving_with ''Generic ''G.HsModule Maybe.Nothing [     ''ShortByteString,      ''ForeignPtr,     ''Array,     ''Var,-    ''GCT.TyCon,+    ''TyCon,     ''IORef,     ''STRef,     ''Bag,

@@ -3,16 +3,16 @@ {-# LANGUAGE CPP #-} module GhcTest where +import Test.HUnit+#if __GLASGOW_HASKELL__ >= 906 import GhcAst import Data.Derive.TopDown.IsInstance import GHC.Generics import qualified "ghc" Language.Haskell.Syntax as G import Utils import Language.Haskell.TH-import Test.HUnit import Types -#if __GLASGOW_HASKELL__ >= 906 genericGhcHsModule = TestCase   (assertEqual "GhcHsModule is instance of Generic"                True

@@ -119,6 +119,8 @@  ghcAst = TestList [genericGhcHsModule] +hsExt = TestList [typeArityHsModule, typeArityHsName]+ main :: IO () main = do   void $ runTestTT derive@@ -126,3 +128,4 @@   void $ runTestTT instances   void $ runTestTT templates   void $ runTestTT ghcAst+  void $ runTestTT hsExt

@@ -21,7 +21,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PackageImports #-} - module Types where import           Arity import           Control.Monad.IO.Class@@ -35,7 +34,7 @@                                                 , D                                                 ) import qualified "haskell-src"  Language.Haskell.Syntax as H-+import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hs -- types for testing  -- ^ simple cases@@ -254,12 +253,14 @@ $(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 +$(strategy_deriving anyclass ''Binary ''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)@@ -289,3 +290,5 @@ $(instance_ ''Binary ''H.HsModule) $(deriving_th (''TypeArity, makeTypeArity) ''H.HsModule) +-- ModuleHead+$(deriving_th (''TypeArity, makeTypeArity) ''Hs.ModuleHead)