path: root/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch

From 9a41401d903f160e11d56fff35c24eb59d97885d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 17 Dec 2013 19:04:40 +0000
Subject: [PATCH] remove TH

---
 src/Generics/Deriving/TH.hs | 354 --------------------------------------------
 1 file changed, 354 deletions(-)

diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs
index 783cb65..9aab713 100644
--- a/src/Generics/Deriving/TH.hs
+++ b/src/Generics/Deriving/TH.hs
@@ -19,18 +19,6 @@
 
 -- Adapted from Generics.Regular.TH
 module Generics.Deriving.TH (
-      
-      deriveMeta
-    , deriveData
-    , deriveConstructors
-    , deriveSelectors
-
-#if __GLASGOW_HASKELL__ < 701
-    , deriveAll
-    , deriveRepresentable0
-    , deriveRep0
-    , simplInstance
-#endif
   ) where
 
 import Generics.Deriving.Base
@@ -41,124 +29,6 @@ import Language.Haskell.TH.Syntax (Lift(..))
 import Data.List (intercalate)
 import Control.Monad
 
--- | Given the names of a generic class, a type to instantiate, a function in
--- the class and the default implementation, generates the code for a basic
--- generic instance.
-simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
-simplInstance cl ty fn df = do
-  i <- reify (genRepName 0 ty)
-  x <- newName "x"
-  let typ = ForallT [PlainTV x] [] 
-        ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) 
-          (typeVariables i)) `AppT` (VarT x))
-  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
-    [funD fn [clause [] (normalB (varE df `appE` 
-      (sigE (global 'undefined) (return typ)))) []]]
-
-
--- | Given the type and the name (as string) for the type to derive,
--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
--- instances, and the 'Representable0' instance.
-deriveAll :: Name -> Q [Dec]
-deriveAll n =
-  do a <- deriveMeta n
-     b <- deriveRepresentable0 n
-     return (a ++ b)
-
--- | Given the type and the name (as string) for the type to derive,
--- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
--- instances.
-deriveMeta :: Name -> Q [Dec]
-deriveMeta n =
-  do a <- deriveData n
-     b <- deriveConstructors n
-     c <- deriveSelectors n
-     return (a ++ b ++ c)
-
--- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
-deriveData :: Name -> Q [Dec]
-deriveData = dataInstance
-
--- | Given a datatype name, derive datatypes and 
--- instances of class 'Constructor'.
-deriveConstructors :: Name -> Q [Dec]
-deriveConstructors = constrInstance
-
--- | Given a datatype name, derive datatypes and instances of class 'Selector'.
-deriveSelectors :: Name -> Q [Dec]
-deriveSelectors = selectInstance
-
--- | Given the type and the name (as string) for the Representable0 type
--- synonym to derive, generate the 'Representable0' instance.
-deriveRepresentable0 :: Name -> Q [Dec]
-deriveRepresentable0 n = do
-    rep0 <- deriveRep0 n
-    inst <- deriveInst n
-    return $ rep0 ++ inst
-
--- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
--- is used.
-deriveRep0 :: Name -> Q [Dec]
-deriveRep0 n = do
-  i <- reify n
-  fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n)
-
-deriveInst :: Name -> Q [Dec]
-deriveInst t = do
-  i <- reify t
-  let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) 
-                (typeVariables i)
-#if __GLASGOW_HASKELL__ >= 707
-  let tyIns = TySynInstD ''Rep (TySynEqn [typ t] (typ (genRepName 0 t)))
-#else
-  let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t))
-#endif
-  fcs <- mkFrom t 1 0 t
-  tcs <- mkTo   t 1 0 t
-  liftM (:[]) $
-    instanceD (cxt []) (conT ''Generic `appT` return (typ t))
-                         [return tyIns, funD 'from fcs, funD 'to tcs]
-
-
-dataInstance :: Name -> Q [Dec]
-dataInstance n = do
-  i <- reify n
-  case i of
-    TyConI (DataD    _ n _ _ _) -> mkInstance n
-    TyConI (NewtypeD _ n _ _ _) -> mkInstance n
-    _ -> return []
-  where
-    mkInstance n = do
-      ds <- mkDataData n
-      is <- mkDataInstance n
-      return $ [ds,is]
-
-constrInstance :: Name -> Q [Dec]
-constrInstance n = do
-  i <- reify n
-  case i of
-    TyConI (DataD    _ n _ cs _) -> mkInstance n cs
-    TyConI (NewtypeD _ n _ c  _) -> mkInstance n [c]
-    _ -> return []
-  where
-    mkInstance n cs = do
-      ds <- mapM (mkConstrData n) cs
-      is <- mapM (mkConstrInstance n) cs
-      return $ ds ++ is
-
-selectInstance :: Name -> Q [Dec]
-selectInstance n = do
-  i <- reify n
-  case i of
-    TyConI (DataD    _ n _ cs _) -> mkInstance n cs
-    TyConI (NewtypeD _ n _ c  _) -> mkInstance n [c]
-    _ -> return []
-  where
-    mkInstance n cs = do
-      ds <- mapM (mkSelectData n) cs
-      is <- mapM (mkSelectInstance n) cs
-      return $ concat (ds ++ is)
-
 typeVariables :: Info -> [TyVarBndr]
 typeVariables (TyConI (DataD    _ _ tv _ _)) = tv
 typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
@@ -179,233 +49,9 @@ genName = mkName . (++"_") . intercalate "_" . map nameBase
 genRepName :: Int -> Name -> Name
 genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase
 
-mkDataData :: Name -> Q Dec
-mkDataData n = dataD (cxt []) (genName [n]) [] [] []
-
-mkConstrData :: Name -> Con -> Q Dec
-mkConstrData dt (NormalC n _) =
-  dataD (cxt []) (genName [dt, n]) [] [] [] 
-mkConstrData dt r@(RecC _ _) =
-  mkConstrData dt (stripRecordNames r)
-mkConstrData dt (InfixC t1 n t2) =
-  mkConstrData dt (NormalC n [t1,t2])
-
-mkSelectData :: Name -> Con -> Q [Dec]
-mkSelectData dt r@(RecC n fs) = return (map one fs)
-  where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] []
-mkSelectData dt _ = return []
-
-
-mkDataInstance :: Name -> Q Dec
-mkDataInstance n =
-  instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n]))
-    [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []]
-    ,funD 'moduleName   [clause [wildP] (normalB (stringE name)) []]]
-  where
-    name = maybe (error "Cannot fetch module name!") id (nameModule n)
-
-instance Lift Fixity where
-  lift Prefix      = conE 'Prefix
-  lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
-
-instance Lift Associativity where
-  lift LeftAssociative  = conE 'LeftAssociative
-  lift RightAssociative = conE 'RightAssociative
-  lift NotAssociative   = conE 'NotAssociative
-
-mkConstrInstance :: Name -> Con -> Q Dec
-mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
-mkConstrInstance dt (RecC    n _) = mkConstrInstanceWith dt n
-      [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
-mkConstrInstance dt (InfixC t1 n t2) =
-    do
-      i <- reify n
-      let fi = case i of
-                 DataConI _ _ _ f -> convertFixity f
-                 _ -> Prefix
-      instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
-        [funD 'conName   [clause [wildP] (normalB (stringE (nameBase n))) []],
-         funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
-  where
-    convertFixity (Fixity n d) = Infix (convertDirection d) n
-    convertDirection InfixL = LeftAssociative
-    convertDirection InfixR = RightAssociative
-    convertDirection InfixN = NotAssociative
-
-mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
-mkConstrInstanceWith dt n extra = 
-  instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
-    (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
-
-mkSelectInstance :: Name -> Con -> Q [Dec]
-mkSelectInstance dt r@(RecC n fs) = return (map one fs) where
-  one (f, _, _) = 
-    InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f]))
-      [FunD 'selName [Clause [WildP] 
-        (NormalB (LitE (StringL (nameBase f)))) []]]
-mkSelectInstance _ _ = return []
-
-rep0Type :: Name -> Q Type
-rep0Type n =
-    do
-      -- runIO $ putStrLn $ "processing " ++ show n
-      i <- reify n
-      let b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  (conT ''D1) `appT` (conT $ genName [dt]) `appT` 
-                    (foldr1' sum (conT ''V1) 
-                      (map (rep0Con (dt, map tyVarBndrToName vs)) cs))
-                TyConI (NewtypeD _ dt vs c _) ->
-                  (conT ''D1) `appT` (conT $ genName [dt]) `appT`
-                    (rep0Con (dt, map tyVarBndrToName vs) c)
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                _ -> error "unknown construct" 
-      --appT b (conT $ mkName (nameBase n))
-      b where
-    sum :: Q Type -> Q Type -> Q Type
-    sum a b = conT ''(:+:) `appT` a `appT` b
-
-
-rep0Con :: (Name, [Name]) -> Con -> Q Type
-rep0Con (dt, vs) (NormalC n []) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-     (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1)
-rep0Con (dt, vs) (NormalC n fs) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-     (foldr1 prod (map (repField (dt, vs) . snd) fs)) where
-    prod :: Q Type -> Q Type -> Q Type
-    prod a b = conT ''(:*:) `appT` a `appT` b
-rep0Con (dt, vs) r@(RecC n []) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1
-rep0Con (dt, vs) r@(RecC n fs) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-      (foldr1 prod (map (repField' (dt, vs) n) fs)) where
-    prod :: Q Type -> Q Type -> Q Type
-    prod a b = conT ''(:*:) `appT` a `appT` b
-
-rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2])
-
---dataDeclToType :: (Name, [Name]) -> Type
---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
-
-repField :: (Name, [Name]) -> Type -> Q Type
---repField d t | t == dataDeclToType d = conT ''I
-repField d t = conT ''S1 `appT` conT ''NoSelector `appT`
-                 (conT ''Rec0 `appT` return t)
-
-repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
-repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f]) 
-                                    `appT` (conT ''Rec0 `appT` return t)
--- Note: we should generate Par0 too, at some point
-
-
-mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
-mkFrom ns m i n =
-    do
-      -- runIO $ putStrLn $ "processing " ++ show n
-      let wrapE e = lrE m i e
-      i <- reify n
-      let b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
-                    (length cs)) [0..] cs
-                TyConI (NewtypeD _ dt vs c _) ->
-                  [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                  -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []]
-                _ -> error "unknown construct"
-      return b
-
-mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
-mkTo ns m i n =
-    do
-      -- runIO $ putStrLn $ "processing " ++ show n
-      let wrapP p = lrP m i p
-      i <- reify n
-      let b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
-                    (length cs)) [0..] cs
-                TyConI (NewtypeD _ dt vs c _) ->
-                  [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                  -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
-                _ -> error "unknown construct" 
-      return b
-
-fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
-fromCon wrap ns (dt, vs) m i (NormalC cn []) =
-  clause
-    [conP cn []]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ 
-      conE 'M1 `appE` (conE 'U1)) []
-fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
-  -- runIO (putStrLn ("constructor " ++ show ix)) >>
-  clause
-    [conP cn (map (varP . field) [0..length fs - 1])]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
-      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
-  where prod x y = conE '(:*:) `appE` x `appE` y
-fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
-  clause
-    [conP cn []]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) []
-fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
-  clause
-    [conP cn (map (varP . field) [0..length fs - 1])]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
-      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
-  where prod x y = conE '(:*:) `appE` x `appE` y
-fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
-  fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
-
-fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
---fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
-fromField (dt, vs) nr t = conE 'M1 `appE` (conE 'K1 `appE` varE (field nr))
-
-toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
-toCon wrap ns (dt, vs) m i (NormalC cn []) =
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]]
-      (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i (NormalC cn fs) =
-    -- runIO (putStrLn ("constructor " ++ show ix)) >>
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1
-        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]]
-      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
-  where prod x y = conP '(:*:) [x,y]
-toCon wrap ns (dt, vs) m i r@(RecC cn []) =
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]]
-      (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1
-        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]]
-      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
-  where prod x y = conP '(:*:) [x,y]
-toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
-  toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
-
-toField :: (Name, [Name]) -> Int -> Type -> Q Pat
---toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
-toField (dt, vs) nr t = conP 'M1 [conP 'K1 [varP (field nr)]]
-
-
 field :: Int -> Name
 field n = mkName $ "f" ++ show n
 
-lrP :: Int -> Int -> (Q Pat -> Q Pat)
-lrP 1 0 p = p
-lrP m 0 p = conP 'L1 [p]
-lrP m i p = conP 'R1 [lrP (m-1) (i-1) p]
-
-lrE :: Int -> Int -> (Q Exp -> Q Exp)
-lrE 1 0 e = e
-lrE m 0 e = conE 'L1 `appE` e
-lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e
 
 trd (_,_,c) = c
 
-- 
1.8.5.1