diff options
Diffstat (limited to 'standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch')
| -rw-r--r-- | standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch | 394 |
1 files changed, 394 insertions, 0 deletions
diff --git a/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch b/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch new file mode 100644 index 000000000..83c8ffd2a --- /dev/null +++ b/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch @@ -0,0 +1,394 @@ +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 + |