mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
git-annex/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch
Joey Hess ccef06da41 allow building webapp with EvilSplicer for non-android arm 
Was able to reuse many of the android patches, but several had to be
re-done. On Android, ghc is a stage2 build, so can compile, but not run TH
code. But debian's ghc on armel cannot even compile TH code, so it has
to be patched out.

Some haskell packages have been updated to new versions, including yesod
and DAV, and their patches had to be redone.

The Makefile now has 2 new targets. The first is run on a companion x86
system to do the build and get TH splices. Then the second target is run
the same source tree on the arm system to build without needing TH.

This commit was sponsored by Svenne Krap.
2013-12-18 21:41:17 +00:00

394 lines
15 KiB
Diff
Raw Blame History

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
Reference in a new issue View git blame Copy permalink