th-typegraph 1.0.2 → 1.4
raw patch · 12 files changed
+1222/−700 lines, 12 filesdep +HUnitdep +attoparsecdep +bytestringdep ~basedep ~template-haskell
Dependencies added: HUnit, attoparsec, bytestring, deepseq, dlist, fail, ghc-prim, hashable, network-uri, scientific, semigroups, sr-extra, tagged, th-typegraph, transformers, unordered-containers, vector
Dependency ranges changed: base, template-haskell
Files
- include/overlapping-compat.h +15/−0
- src/Data/SafeCopy/Derive.hs +506/−0
- src/Language/Haskell/TH/TypeGraph/Constraints.hs +241/−0
- src/Language/Haskell/TH/TypeGraph/Orphans.hs +3/−53
- src/Language/Haskell/TH/TypeGraph/Phantom.hs +3/−3
- src/Language/Haskell/TH/TypeGraph/Prelude.hs +106/−0
- src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs +0/−475
- src/Language/Haskell/TH/TypeGraph/Serialize.hs +137/−0
- src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs +44/−141
- src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs +45/−25
- test/Main.hs +93/−0
- th-typegraph.cabal +29/−3
+ include/overlapping-compat.h view
@@ -0,0 +1,15 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_ {-# OVERLAPPING #-}+#ifdef NEEDS_INCOHERENT+#define INCOHERENT_ {-# INCOHERENT #-}+#endif+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#ifdef NEEDS_INCOHERENT+{-# LANGUAGE IncoherentInstances #-}+#define INCOHERENT_+#endif+#endif
+ src/Data/SafeCopy/Derive.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++-- Hack for bug in older Cabal versions+#ifndef MIN_VERSION_template_haskell+#define MIN_VERSION_template_haskell(x,y,z) 1+#endif++module Data.SafeCopy.Derive where++import Language.Haskell.TH.TypeGraph.Phantom (nonPhantom)+import Language.Haskell.TH.TypeGraph.Prelude (pprint1)+import Data.Serialize (getWord8, putWord8, label)+import Data.SafeCopy++#if MIN_VERSION_template_haskell(2,8,0)+import Language.Haskell.TH hiding (Kind)+#else+import Language.Haskell.TH hiding (Kind(..))+#endif+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Data.Maybe (fromMaybe)+#ifdef __HADDOCK__+import Data.Word (Word8) -- Haddock+#endif+import Data.Int (Int32)++-- | FIXME - Bogus reimplementation of the hidden+-- Data.SafeCopy.unVersion function+unVersion :: Version a -> Int32+unVersion v = read (takeWhile (/= '}') (drop 21 (show v)))++-- | Derive an instance of 'SafeCopy'.+--+-- When serializing, we put a 'Word8' describing the+-- constructor (if the data type has more than one+-- constructor). For each type used in the constructor, we+-- call 'getSafePut' (which immediately serializes the version+-- of the type). Then, for each field in the constructor, we+-- use one of the put functions obtained in the last step.+--+-- For example, given the data type and the declaration below+--+-- @+--data T0 b = T0 b Int+--deriveSafeCopy 1 'base ''T0+-- @+--+-- we generate+--+-- @+--instance (SafeCopy a, SafeCopy b) =>+-- SafeCopy (T0 b) where+-- putCopy (T0 arg1 arg2) = contain $ do put_b <- getSafePut+-- put_Int <- getSafePut+-- put_b arg1+-- put_Int arg2+-- return ()+-- getCopy = contain $ do get_b <- getSafeGet+-- get_Int <- getSafeGet+-- return T0 \<*\> get_b \<*\> get_Int+-- version = 1+-- kind = base+-- @+--+-- And, should we create another data type as a newer version of @T0@, such as+--+-- @+--data T a b = C a a | D b Int+--deriveSafeCopy 2 'extension ''T+--+--instance SafeCopy b => Migrate (T a b) where+-- type MigrateFrom (T a b) = T0 b+-- migrate (T0 b i) = D b i+-- @+--+-- we generate+--+-- @+--instance (SafeCopy a, SafeCopy b) =>+-- SafeCopy (T a b) where+-- putCopy (C arg1 arg2) = contain $ do putWord8 0+-- put_a <- getSafePut+-- put_a arg1+-- put_a arg2+-- return ()+-- putCopy (D arg1 arg2) = contain $ do putWord8 1+-- put_b <- getSafePut+-- put_Int <- getSafePut+-- put_b arg1+-- put_Int arg2+-- return ()+-- getCopy = contain $ do tag <- getWord8+-- case tag of+-- 0 -> do get_a <- getSafeGet+-- return C \<*\> get_a \<*\> get_a+-- 1 -> do get_b <- getSafeGet+-- get_Int <- getSafeGet+-- return D \<*\> get_b \<*\> get_Int+-- _ -> fail $ \"Could not identify tag \\\"\" +++-- show tag ++ \"\\\" for type Main.T \" +++-- \"that has only 2 constructors. \" +++-- \"Maybe your data is corrupted?\"+-- version = 2+-- kind = extension+-- @+--+-- Note that by using getSafePut, we saved 4 bytes in the case+-- of the @C@ constructor. For @D@ and @T0@, we didn't save+-- anything. The instance derived by this function always use+-- at most the same space as those generated by+-- 'deriveSafeCopySimple', but never more (as we don't call+-- 'getSafePut'/'getSafeGet' for types that aren't needed).+--+-- Note that you may use 'deriveSafeCopySimple' with one+-- version of your data type and 'deriveSafeCopy' in another+-- version without any problems.+deriveSafeCopy :: Version a -> Name -> TypeQ -> Q [Dec]+deriveSafeCopy = internalDeriveSafeCopy Normal++deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [TypeQ] -> Q [Dec]+deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal++-- | Derive an instance of 'SafeCopy'. The instance derived by+-- this function is simpler than the one derived by+-- 'deriveSafeCopy' in that we always use 'safePut' and+-- 'safeGet' (instead of 'getSafePut' and 'getSafeGet').+--+-- When serializing, we put a 'Word8' describing the+-- constructor (if the data type has more than one constructor)+-- and, for each field of the constructor, we use 'safePut'.+--+-- For example, given the data type and the declaration below+--+-- @+--data T a b = C a a | D b Int+--deriveSafeCopySimple 1 'base ''T+-- @+--+-- we generate+--+-- @+--instance (SafeCopy a, SafeCopy b) =>+-- SafeCopy (T a b) where+-- putCopy (C arg1 arg2) = contain $ do putWord8 0+-- safePut arg1+-- safePut arg2+-- return ()+-- putCopy (D arg1 arg2) = contain $ do putWord8 1+-- safePut arg1+-- safePut arg2+-- return ()+-- getCopy = contain $ do tag <- getWord8+-- case tag of+-- 0 -> do return C \<*\> safeGet \<*\> safeGet+-- 1 -> do return D \<*\> safeGet \<*\> safeGet+-- _ -> fail $ \"Could not identify tag \\\"\" +++-- show tag ++ \"\\\" for type Main.T \" +++-- \"that has only 2 constructors. \" +++-- \"Maybe your data is corrupted?\"+-- version = 1+-- kind = base+-- @+--+-- Using this simpler instance means that you may spend more+-- bytes when serializing data. On the other hand, it is more+-- straightforward and may match any other format you used in+-- the past.+--+-- Note that you may use 'deriveSafeCopy' with one version of+-- your data type and 'deriveSafeCopySimple' in another version+-- without any problems.+deriveSafeCopySimple :: Version a -> Name -> TypeQ -> Q [Dec]+deriveSafeCopySimple = internalDeriveSafeCopy Simple++deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [TypeQ] -> Q [Dec]+deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple++-- | Derive an instance of 'SafeCopy'. The instance derived by+-- this function should be compatible with the instance derived+-- by the module @Happstack.Data.SerializeTH@ of the+-- @happstack-data@ package. The instances use only 'safePut'+-- and 'safeGet' (as do the instances created by+-- 'deriveSafeCopySimple'), but we also always write a 'Word8'+-- tag, even if the data type isn't a sum type.+--+-- For example, given the data type and the declaration below+--+-- @+--data T0 b = T0 b Int+--deriveSafeCopy 1 'base ''T0+-- @+--+-- we generate+--+-- @+--instance (SafeCopy a, SafeCopy b) =>+-- SafeCopy (T0 b) where+-- putCopy (T0 arg1 arg2) = contain $ do putWord8 0+-- safePut arg1+-- safePut arg2+-- return ()+-- getCopy = contain $ do tag <- getWord8+-- case tag of+-- 0 -> do return T0 \<*\> safeGet \<*\> safeGet+-- _ -> fail $ \"Could not identify tag \\\"\" +++-- show tag ++ \"\\\" for type Main.T0 \" +++-- \"that has only 1 constructors. \" +++-- \"Maybe your data is corrupted?\"+-- version = 1+-- kind = base+-- @+--+-- This instance always consumes at least the same space as+-- 'deriveSafeCopy' or 'deriveSafeCopySimple', but may use more+-- because of the useless tag. So we recomend using it only if+-- you really need to read a previous version in this format,+-- and not for newer versions.+--+-- Note that you may use 'deriveSafeCopy' with one version of+-- your data type and 'deriveSafeCopyHappstackData' in another version+-- without any problems.+deriveSafeCopyHappstackData :: Version a -> Name -> TypeQ -> Q [Dec]+deriveSafeCopyHappstackData = internalDeriveSafeCopy HappstackData++deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [TypeQ] -> Q [Dec]+deriveSafeCopyHappstackDataIndexedType = internalDeriveSafeCopyIndexedType HappstackData++data DeriveType = Normal | Simple | HappstackData++forceTag :: DeriveType -> Bool+forceTag HappstackData = True+forceTag _ = False++tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV n) = n+#if MIN_VERSION_template_haskell(2,10,0)+tyVarName (KindedTV n _) = n+#endif++-- | Turn type applications into a type parameter list+decomposeType :: Type -> [Type]+decomposeType t0 = go t0 []+ where go (AppT t1 t2) ts = go t1 (t2 : ts)+ go t ts = t : ts++-- | Turn a type parameter list into type applications+composeType :: [Type] -> Type+composeType ts = foldl1 AppT ts++internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> TypeQ -> Q [Dec]+internalDeriveSafeCopy deriveType versionId kindName egValueType = do+ egValueType' <- egValueType+#if 1+ case decomposeType egValueType' of+ (ConT tyName : _) -> do+ info <- reify tyName+ internalDeriveSafeCopy' deriveType versionId kindName egValueType' info+#else+ case egValueType' of+ ConT tyName -> do+ info <- reify tyName+ internalDeriveSafeCopy' deriveType versionId kindName egValueType' info+ AppT (ConT egValueTypeName) (ConT _) -> do+ egValueTypeInfo <- reify egValueTypeName+ internalDeriveSafeCopy' deriveType versionId kindName egValueType' egValueTypeInfo+#endif+ typ -> error ("deriveSafeCopy - no support for type: " ++ pprint typ)++internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Type -> Info -> Q [Dec]+internalDeriveSafeCopy' deriveType versionId kindName typ info = do+ case info of+#if MIN_VERSION_template_haskell(2,11,0)+ TyConI (DataD context _name tyvars _kind cons _derivs)+#else+ TyConI (DataD context _name tyvars cons _derivs)+#endif+ | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ pprint typ +++ ". The datatype must have less than 256 constructors."+ | otherwise -> worker context tyvars (zip [0..] cons)++#if MIN_VERSION_template_haskell(2,11,0)+ TyConI (NewtypeD context _name tyvars _kind con _derivs) ->+#else+ TyConI (NewtypeD context _name tyvars con _derivs) ->+#endif+ worker context tyvars [(0, con)]++ FamilyI _ insts -> do+ decs <- forM insts $ \inst ->+ case inst of+#if MIN_VERSION_template_haskell(2,11,0)+ DataInstD context name ty _kind cons _derivs ->+#else+ DataInstD context name ty cons _derivs ->+#endif+ if typ == composeType (ConT name : ty)+ then (worker' (pure typ) context [] (zip [0..] cons))+ else return []++#if MIN_VERSION_template_haskell(2,11,0)+ NewtypeInstD context name ty _kind con _derivs ->+#else+ NewtypeInstD context name ty con _derivs ->+#endif+ if typ == composeType (ConT name : ty)+ then worker' (pure typ) context [] [(0, con)]+ else return []+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (typ, inst)+ return $ concat decs+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (typ, info)+ where+ worker = worker' (pure typ)+ worker' tyBase context tyvars cons =+ (case typ of+ ConT tyName -> nonPhantom tyName -- Only works on type names right now+ _ -> pure (map (VarT . tyVarName) tyvars)) >>= \tyvars' ->+ let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]+#if MIN_VERSION_template_haskell(2,10,0)+ safeCopyClass args = foldl appT (conT ''SafeCopy) args+#else+ safeCopyClass args = classP ''SafeCopy args+#endif+ in (:[]) <$> instanceD (cxt $ [safeCopyClass [pure typ'] | typ' <- tyvars'] ++ map return context ++ migrateFromKind ty kindName)+ (conT ''SafeCopy `appT` ty)+ [ mkPutCopy deriveType cons+ , mkGetCopy deriveType typ cons+ , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []+ , valD (varP 'kind) (normalB (varE kindName)) []+ , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (pprint1 typ)) []]+ ]+ -- This adds Migrate Foo to the superclasses of SafeCopy Foo if+ -- the kind is extension. This lets us defer the actual+ -- implementation of the Migrate instance, which is harmless and+ -- sometimes useful.+ migrateFromKind ty name =+ if name == 'extension then [appT (conT ''Migrate) ty] else []++internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [TypeQ] -> Q [Dec]+internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do+ info <- reify tyName+ internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info++internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [TypeQ] -> Info -> Q [Dec]+internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info = do+ tyIndex <- sequence tyIndex'+ typ <- foldl appT (conT tyName) tyIndex'+ case info of+ FamilyI _ insts -> do+ decs <- forM insts $ \inst ->+ case inst of+#if MIN_VERSION_template_haskell(2,11,0)+ DataInstD context _name ty _kind cons _derivs+#else+ DataInstD context _name ty cons _derivs+#endif+ | ty == tyIndex ->+ worker' typ (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)+ | otherwise ->+ return []++#if MIN_VERSION_template_haskell(2,11,0)+ NewtypeInstD context _name ty _kind con _derivs+#else+ NewtypeInstD context _name ty con _derivs+#endif+ | ty == tyIndex ->+ worker' typ (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]+ | otherwise ->+ return []+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)+ return $ concat decs+ _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)+ where+ worker' typ tyBase context tyvars cons =+ let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]+#if MIN_VERSION_template_haskell(2,10,0)+ safeCopyClass args = foldl appT (conT ''SafeCopy) args+#else+ safeCopyClass args = classP ''SafeCopy args+#endif+ in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)+ (conT ''SafeCopy `appT` ty)+ [ mkPutCopy deriveType cons+ , mkGetCopy deriveType typ cons+ , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []+ , valD (varP 'kind) (normalB (varE kindName)) []+ , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (pprint1 typ)) []]+ ]++mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ+mkPutCopy deriveType cons = funD 'putCopy $ map mkPutClause cons+ where+ manyConstructors = length cons > 1 || forceTag deriveType+ mkPutClause (conNumber, con)+ = do putVars <- mapM (\n -> newName ("a" ++ show n)) [1..conSize con]+ (putFunsDecs, putFuns) <- case deriveType of+ Normal -> mkSafeFunctions "safePut_" 'getSafePut con+ _ -> return ([], const 'safePut)+ let putClause = conP (conName con) (map varP putVars)+ putCopyBody = varE 'contain `appE` doE (+ [ noBindS $ varE 'putWord8 `appE` litE (IntegerL conNumber) | manyConstructors ] +++ putFunsDecs +++ [ noBindS $ varE (putFuns typ) `appE` varE var | (typ, var) <- zip (conTypes con) putVars ] +++ [ noBindS $ varE 'return `appE` tupE [] ])+ clause [putClause] (normalB putCopyBody) []++mkGetCopy :: DeriveType -> Type -> [(Integer, Con)] -> DecQ+mkGetCopy deriveType typ cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) []+ where+ mkLabel = varE 'label `appE` litE (stringL labelString) `appE` getCopyBody+ labelString = pprint1 typ ++ ":"+ getCopyBody+ = case cons of+ [(_, con)] | not (forceTag deriveType) -> mkGetBody con+ _ -> do+ tagVar <- newName "tag"+ doE [ bindS (varP tagVar) (varE 'getWord8)+ , noBindS $ caseE (varE tagVar) (+ [ match (litP $ IntegerL i) (normalB $ mkGetBody con) [] | (i, con) <- cons ] +++ [ match wildP (normalB $ varE 'fail `appE` errorMsg tagVar) [] ]) ]+ mkGetBody con+ = do (getFunsDecs, getFuns) <- case deriveType of+ Normal -> mkSafeFunctions "safeGet_" 'getSafeGet con+ _ -> return ([], const 'safeGet)+ let getBase = appE (varE 'return) (conE (conName con))+ getArgs = foldl (\a t -> infixE (Just a) (varE '(<*>)) (Just (varE (getFuns t)))) getBase (conTypes con)+ doE (getFunsDecs ++ [noBindS getArgs])+ errorMsg tagVar = infixE (Just $ strE str1) (varE '(++)) $ Just $+ infixE (Just tagStr) (varE '(++)) (Just $ strE str2)+ where+ strE = litE . StringL+ tagStr = varE 'show `appE` varE tagVar+ str1 = "Could not identify tag \""+ str2 = concat [ "\" for type "+ , pprint typ+ , " that has only "+ , show (length cons)+ , " constructors. Maybe your data is corrupted?" ]++mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Type -> Name)+mkSafeFunctions name baseFun con = do let origTypes = conTypes con+ realTypes <- mapM followSynonyms origTypes+ finish (zip origTypes realTypes) <$> foldM go ([], []) realTypes+ where go (ds, fs) t+ | found = return (ds, fs)+ | otherwise = do funVar <- newName (name ++ typeName t)+ return ( bindS (varP funVar) (varE baseFun) : ds+ , (t, funVar) : fs )+ where found = any ((== t) . fst) fs+ finish+ :: [(Type, Type)] -- "dictionary" from synonyms(or not) to real types+ -> ([StmtQ], [(Type, Name)]) -- statements+ -> ([StmtQ], Type -> Name) -- function body and name-generator+ finish typeList (ds, fs) = (reverse ds, getName)+ where getName typ = fromMaybe err $ lookup typ typeList >>= flip lookup fs+ err = error "mkSafeFunctions: never here"++-- | Follow type synonyms. This allows us to see, for example,+-- that @[Char]@ and @String@ are the same type and we just need+-- to call 'getSafePut' or 'getSafeGet' once for both.+followSynonyms :: Type -> Q Type+followSynonyms t@(ConT name)+ = maybe (return t) followSynonyms =<<+ recover (return Nothing) (do info <- reify name+ return $ case info of+ TyVarI _ ty -> Just ty+ TyConI (TySynD _ _ ty) -> Just ty+ _ -> Nothing)+followSynonyms (AppT ty1 ty2) = liftM2 AppT (followSynonyms ty1) (followSynonyms ty2)+followSynonyms (SigT ty k) = liftM (flip SigT k) (followSynonyms ty)+followSynonyms t = return t++conSize :: Con -> Int+conSize (NormalC _name args) = length args+conSize (RecC _name recs) = length recs+conSize InfixC{} = 2+conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."+#if MIN_VERSION_template_haskell(2,11,0)+conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."+conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."+#endif++conName :: Con -> Name+conName (NormalC name _args) = name+conName (RecC name _recs) = name+conName (InfixC _ name _) = name+conName _ = error "conName: never here"++conTypes :: Con -> [Type]+conTypes (NormalC _name args) = [t | (_, t) <- args]+conTypes (RecC _name args) = [t | (_, _, t) <- args]+conTypes (InfixC (_, t1) _ (_, t2)) = [t1, t2]+conTypes _ = error "conName: never here"++typeName :: Type -> String+typeName (VarT name) = nameBase name+typeName (ConT name) = nameBase name+typeName (TupleT n) = "Tuple" ++ show n+typeName ArrowT = "Arrow"+typeName ListT = "List"+typeName (AppT t u) = typeName t ++ typeName u+typeName (SigT t _k) = typeName t+typeName _ = "_"
+ src/Language/Haskell/TH/TypeGraph/Constraints.hs view
@@ -0,0 +1,241 @@+-- | This module was developed to replace the deriveConstraints function in aeson,+-- but it probably could replace the code provided here for SafeCopy+-- and PathInfo.++{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, NamedFieldPuns,+ RankNTypes, UndecidableInstances #-}+{-# OPTIONS -Wall #-}++module Language.Haskell.TH.TypeGraph.Constraints+ ( deriveConstraints, monomorphize+ , withBindings, decompose, compose, toName+ ) where++import Control.Monad (MonadPlus, msum, when)+import Control.Monad.RWS (ask, execRWST, get, local, modify, MonadReader, tell, RWST)+import Control.Monad.Trans (lift)+import Data.Generics (Data, everywhere, mkT, listify, Typeable)+import Data.Map as Map (fromList, lookup, Map)+import Data.Set as Set (delete, empty, fromList, insert, member, Set, singleton)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Quasi)+import Language.Haskell.TH.TypeGraph.Prelude (pprint1, toName)++-- Reader monad type+data R =+ R { paramNames :: Set Name+ , verbosity :: Int+ , prefix :: String }++monomorphize :: TypeQ -> Q Type+monomorphize typq = typq >>= \typ0 -> go typ0 $ decompose typ0+ where+ go typ0 (ConT tname : vals) = reify tname >>= goInfo typ0 vals+ go typ0 _ = error $ "monomorphize - unexpected type " ++ pprint1 typ0+ goInfo _typ0 vals (TyConI dec) = goDec vals dec+ goInfo _typ0 vals (FamilyI dec _insts) = goDec vals dec+ goInfo typ0 _vals info = error $ "monomorphize - unexpected type " ++ pprint1 info ++ " (via " ++ pprint1 typ0 ++ ")"+#if MIN_VERSION_template_haskell(2,11,0)+ goDec vals (DataD _ tname vars _ _ _) = goVars (ConT tname) vals vars+ goDec vals (NewtypeD _ tname vars _ _ _) = goVars (ConT tname) vals vars+#else+ goDec vals (DataD _ tname vars _ _) = goVars (ConT tname) vals vars+ goDec vals (NewtypeD _ tname vars _ _) = goVars (ConT tname) vals vars+#endif+ -- These type variables are parameters to the data family type+ -- function, not to the type resulting from using the type+ -- function. Therefore we do not bind them to the vals+ -- argument, they are unified with each instance.+ goDec vals (TySynD _tname vars typ) =+ withBindings vars vals (\unbound subst -> go (subst typ) (decompose typ ++ unbound))+#if MIN_VERSION_template_haskell(2,11,0)+ goDec vals (DataFamilyD fname fvars mkind) = do+#else+ goDec vals (FamilyD DataFam fname fvars mkind) = do+#endif+ -- We can learn the arity of this type from its kind.+ -- Then we can create extra type variables to make this+ -- monomorphic.+ let ftype = compose (ConT fname : map (VarT . toName) fvars)+ vars <- let kind = maybe [StarT] decompose mkind in+ mapM (\n -> newName ("t" ++ show n)) [1..(length kind - length fvars)]+ goVars ftype vals (fvars ++ map PlainTV vars)+ goDec vals dec = error $ "monomorphize - unexpected dec " ++ pprint1 dec ++ "(type params " ++ pprint1 (compose vals) ++ ")"+ goVars :: Type -> [Type] -> [TyVarBndr] -> Q Type+ goVars typ vals vars =+ if length vars < length vals+ then error $ "monomorphize - too many types applied to " ++ pprint1 typ ++ "\n vars=" ++ show vars ++ "\n vals=" ++ show vals+ else -- Extend the type list to match the var list by+ -- applying VarT to the extra variables.+ let vals' = vals ++ map (VarT . toName) (drop (length vals) vars) in+ -- Build the monomorphic type and apply substitutions+ withBindings vars vals (\unbound subst -> return (subst (compose (typ : vals'))))++deriveConstraints :: Int -> Name -> Name -> [Type] -> Q (Set Pred)+deriveConstraints verbosity0 constraint tyConName varTysExp = do+ typ <- monomorphize (pure (compose (ConT tyConName : varTysExp)))+ (_, preds) <-+ execRWST (go typ)+ (R { paramNames = Set.fromList (gFind varTysExp) :: Set Name+ , verbosity = verbosity0+ , prefix = "" })+ Set.empty+ return $ Set.delete (AppT (ConT constraint) (compose (ConT tyConName : varTysExp))) preds+ where+ go typ = do+ message 1 ("monomorphized: " ++ show typ)+ params <- paramNames <$> ask+ message 1 ("paramNames=" ++ show params)+ message 1 ("\nderiveConstraints " +++ pprint constraint +++ " (" ++ pprint (compose (ConT tyConName : varTysExp)) ++ ")")+ local (\r -> r {prefix = " " ++ prefix r}) $+ goType [] (compose (ConT tyConName : varTysExp))++ goType :: [Type] -> Type -> RWST R (Set Pred) (Set Type) Q ()+ goType vals typ = do+ visited <- get+ when (not (Set.member typ visited)) $ do+ modify (Set.insert typ)+ message 1 ("goType " ++ pprint typ)+ local (\r -> r {prefix = " " ++ prefix r}) $ do+ message 1 ("ts=" ++ show (decompose typ))+ goApply (decompose typ ++ vals)++ -- Process an unvisited type whose applications have been decomposed+ goApply :: [Type] -> RWST R (Set Pred) (Set Type) Q ()+ goApply [VarT name] = do+ message 1 ("goApply name=" ++ pprint name)+ -- params <- paramNames <$> ask+ -- Constraints are only interesting if they involve one of the+ -- type's parameters.+ let p = AppT (ConT constraint) (VarT name)+ tell (Set.singleton p)+{-+ when (Set.member name params)+ (do message 1 ("constraint: " ++ pprint p)+ tell (Set.singleton p))+-}+ -- Strip off kind signature (I should do something with this -+ -- it indicates whether the type is monomorphic.)+ goApply [SigT typ _kind] = goApply (decompose typ)+ -- goApplied [SigT _typ kind] = return ()+ goApply [ListT, val] = goType [] val+ goApply (TupleT _ : types) = mapM_ (goType []) types+ goApply (ConT tname : vals) = do+ info <- lift (reify tname)+ message 1 ("info=" ++ show info)+ goInfo vals info+ goApply (typ : _) = error ("goApplied - unexpected (unimplemented?) type: " ++ show typ ++ "\n typ0=" ++ pprint (compose (ConT tyConName : varTysExp)))+ goApply [] = error "Impossible value passed to goApplied"++ goInfo :: [Type] -> Info -> RWST R (Set Pred) (Set Type) Q ()+ goInfo vals (TyConI (TySynD _tname vars typ)) =+ withBindings vars vals (\unbound subst -> goType unbound (subst typ))+ goInfo _vals (PrimTyConI _ _ _) = return ()+ goInfo vals (TyConI dec) =+ let (vars, cons) = decInfo dec in+ withBindings vars vals (\unbound subst -> mapM_ (goCon unbound subst) cons)+ goInfo vals (FamilyI fam _insts) =+ let (famname, vars) = famInfo fam in+ withBindings vars vals+ (\unbound subst -> do+ let typ = subst (compose (ConT famname : fmap (VarT . toName) vars ++ unbound))+ params <- paramNames <$> ask+ message 1 ("paramNames=" ++ show params)+ message 1 ("typ=" ++ show typ)+ let p = AppT (ConT constraint) typ+ tell (Set.singleton p)+{-+ if any (`Set.member` params) (gFind typ :: [Name])+ then do+ message 1 ("family constraint: " ++ pprint p)+ tell (Set.singleton p)+ else message 1 ("family constraint rejected: " ++ pprint1 p)+-}+ )+ goInfo _vals info = error ("deriveConstraints info=" ++ show info)++ decInfo :: Dec -> ([TyVarBndr], [Con])+#if MIN_VERSION_template_haskell(2,11,0)+ decInfo (DataD _cxt _tname vars _ cons _supers) = (vars, cons)+ decInfo (NewtypeD cx tname vars _ con supers) = (vars, [con])+#else+ decInfo (DataD _cxt _tname vars cons _supers) = (vars, cons)+ decInfo (NewtypeD _cx _tname vars con _supers) = (vars, [con])+#endif+ decInfo dec = error $ "unexpected Dec: " ++ pprint1 dec++#if MIN_VERSION_template_haskell(2,11,0)+ famInfo (DataFamilyD famname vars _mk) = (famname, vars)+#else+ famInfo (FamilyD DataFam famname vars _mk) = (famname, vars)+#endif+ famInfo fam = error $ "unexpected Dec: " ++ pprint1 fam++ goCon :: [Type] -> (Type -> Type) -> Con -> RWST R (Set Pred) (Set Type) Q ()+ goCon vals subst (ForallC _ _ con) =+ goCon vals subst con+ goCon vals subst (NormalC _cname sts) =+ mapM_ (goField vals subst . snd) sts+ goCon vals subst (RecC _cname vsts) =+ mapM_ (goField vals subst . (\(_,_,x) -> x)) vsts+ goCon vals subst (InfixC lhs _cname rhs) = do+ goField vals subst (snd lhs)+ goField vals subst (snd rhs)++ -- goField :: Data a => Name -> (a -> a) -> Int -> Int -> Name -> Type -> WriterT (Set Pred) Q ()+ goField vals subst ftype = goType vals (subst ftype)++-- | Input is a list of type variable bindings (such as those+-- appearing in a Dec) and the current stack of type parameters+-- applied by AppT. Builds a function that expands a type using those+-- bindings and pass it to an action.+withBindings :: (Monad m, Data a) => [TyVarBndr] -> [Type] -> ([Type] -> (a -> a) -> m r) -> m r+withBindings vars vals action = do+ -- when (length vals < length vars)+ -- (error $ "doInfo - arity mismatch:\n\tvars=" ++ show vars +++ -- "\n\tparams=" ++ show vals)+ let subst :: forall a. Data a => a -> a+ subst = substG bindings+ -- If there are more values than variables pass the extra+ -- unbound values to action.+ (vals', unbound) = splitAt (length vars) vals+ -- Make the type monomorphic by using the variable list to+ -- extend the list of values as necessary with self bindings.+ -- This prevents the arity mismatch error commented out above.+ vals'' = vals' ++ map (VarT . toName) (drop (length vals') vars)+ bindings = Map.fromList (zip (fmap toName vars) vals'')+ action unbound subst+ where+ -- Build a generic substitution function+ substG :: forall a. Data a => Map Name Type -> a -> a+ substG bindings typ = everywhere (mkT (subst1 bindings)) typ++ subst1 :: Map Name Type -> Type -> Type+ subst1 bindings t@(VarT name) = maybe t id (Map.lookup name bindings)+ subst1 _ t = t++gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b+gFind = msum . map return . listify (const True)++decompose :: Type -> [Type]+decompose t0 = go t0 []+ where go (AppT t1 t2) ts = go t1 (t2 : ts)+ go t ts = t : ts++compose :: [Type] -> Type+compose types = foldl1 AppT types++-- | Output a verbosity controlled error message with the current+-- indentation.+message :: (Quasi m, MonadReader R m) =>+ Int -> String -> m ()+message minv s = do+ v <- verbosity <$> ask+ p <- prefix <$> ask+ when (v >= minv) $ (runQ . runIO . putStr . indent p) s++-- | Indent the lines of a message.+indent :: String -> String -> String+indent p s = unlines $ fmap (p ++) (lines s)
src/Language/Haskell/TH/TypeGraph/Orphans.hs view
@@ -7,18 +7,14 @@ module Language.Haskell.TH.TypeGraph.Orphans where -import Data.Aeson (FromJSON(parseJSON), Value(Null), ToJSON(toJSON))-#if MIN_VERSION_aeson(1,0,0)-import Data.Aeson (ToJSONKey, FromJSONKey)-#endif-#if !MIN_VERSION_aeson(0,11,0)-import Data.Aeson.Types (typeMismatch)-#endif import qualified Data.Graph.Inductive as G import Data.Proxy (Proxy(Proxy))+import Data.SafeCopy (base, contain, deriveSafeCopy, SafeCopy(errorTypeName, getCopy, kind, putCopy, version))+import Data.Serialize (label, Serialize(..)) import Data.Set as Set (Set, toList) import Data.Time (UTCTime(..), Day(ModifiedJulianDay), toModifiedJulianDay, DiffTime) import Data.UserId (UserId(..))+import Extra.Orphans () import Instances.TH.Lift () import Language.Haskell.TH (ExpQ, Loc(..), location, Name, NameSpace, Type) import Language.Haskell.TH.Instances ({-instance Lift Loc-})@@ -26,21 +22,7 @@ import Language.Haskell.TH.Ppr (Ppr(ppr)) import Language.Haskell.TH.PprLib (hcat, ptext, vcat) import Language.Haskell.TH.Syntax (ModName(..), NameFlavour(..), OccName(..), PkgName(..))-import Data.SafeCopy (base, contain, deriveSafeCopy, SafeCopy(errorTypeName, getCopy, kind, putCopy, version))-import Data.Serialize (label, Serialize(..)) -#if !MIN_VERSION_aeson(0,11,0)--- Backport the JSON instances from aeson-0.11.-instance ToJSON (Proxy a) where- toJSON _ = Null- {-# INLINE toJSON #-}--instance FromJSON (Proxy a) where- {-# INLINE parseJSON #-}- parseJSON Null = pure Proxy- parseJSON v = typeMismatch "Proxy" v-#endif- instance Ppr () where ppr () = ptext "()" @@ -55,13 +37,6 @@ instance Ppr (Set Type) where ppr s = hcat [ptext "Set.fromList [", ppr (Set.toList s), ptext "]"] -instance SafeCopy (Proxy t) where- putCopy Proxy = contain (do { return () })- getCopy = contain (label "Data.Proxy.Proxy:" (pure Proxy))- version = 0- kind = base- errorTypeName _ = "Data.Proxy.Proxy"- $(deriveSafeCopy 0 'base ''OccName) $(deriveSafeCopy 0 'base ''NameSpace) $(deriveSafeCopy 0 'base ''PkgName)@@ -69,28 +44,3 @@ $(deriveSafeCopy 0 'base ''NameFlavour) $(deriveSafeCopy 0 'base ''Name) $(deriveSafeCopy 1 'base ''Loc)--instance Serialize UTCTime where- get = uncurry UTCTime <$> get- put (UTCTime day time) = put (day, time)--instance Serialize Day where- get = ModifiedJulianDay <$> get- put = put . toModifiedJulianDay--instance Serialize DiffTime where- get = fromRational <$> get- put = put . toRational--#if MIN_VERSION_aeson(1,0,0)-instance FromJSONKey UserId-instance ToJSONKey UserId-#endif--deriving instance Serialize UserId-deriving instance Serialize Loc--$(deriveLift ''UserId)--$(deriveLift ''G.Gr)-$(deriveLift ''G.NodeMap)
src/Language/Haskell/TH/TypeGraph/Phantom.hs view
@@ -14,6 +14,7 @@ import Control.Lens ((%=), _1, makeLenses, over, use, view) import Control.Monad.RWS hiding (lift)+import Language.Haskell.TH.TypeGraph.Prelude (expandType, HasMessageInfo(..), message, pprint1, toName) import Language.Haskell.TH.TypeGraph.TypeTraversal import Data.Set as Set import Language.Haskell.TH@@ -65,12 +66,11 @@ _ -> pure () instance DsMonad m => HasTypeTraversal (RWST R () S m) where- prepType = return doTypeInternal = \typ -> message 1 ("doTypeInternal " ++ show typ) >> local (over prefix' (++ " ")) (doApply typ typ) doListT = \typ0 etyp -> message 1 ("doListT " ++ pprint1 typ0) >> doType etyp doTupleT = \_ etyp _ -> message 1 ("doTupleT " ++ show etyp) >> doType etyp- doField = \_t0 _ fi@(FieldInfo {..}) -> message 1 ("doField " ++ show fi) >> doType _fieldType- doVarT = \_ name -> message 1 ("doVarT " ++ show name) >> result %= Set.insert (VarT name)+ doField = \_t0 tname _cpos cname fpos _mfname ftype -> message 1 ("doField " ++ show (tname, cname, fpos, ppr ftype)) >> doType ftype+ doVarT = \_ typ -> message 1 ("doVarT " ++ pprint1 typ) >> result %= Set.insert typ nonPhantom :: DsMonad m => Name -> m [Type] nonPhantom tname =
+ src/Language/Haskell/TH/TypeGraph/Prelude.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS -Wall #-}++module Language.Haskell.TH.TypeGraph.Prelude+ ( expandType, pprint1, pprint1', pprintW, pprintW'+ , ToName(toName)+ , HasMessageInfo(..), message, indent+ , composeType+ , decomposeType+ -- , unfoldType+ ) where++import Control.Lens (Lens', view)+import Control.Monad.RWS as Monad hiding (lift)+import Data.Generics (Data, everywhere, mkT)+import Instances.TH.Lift ()+import Language.Haskell.TH hiding (prim)+import Language.Haskell.TH.Desugar as DS (DsMonad, typeToTH, dsType, expand)+import Language.Haskell.TH.PprLib (to_HPJ_Doc)+import Language.Haskell.TH.Syntax as TH (Name(Name), NameFlavour(NameS), Quasi, VarStrictType)+import Language.Haskell.TH.TypeGraph.Orphans ()+import qualified Text.PrettyPrint as HPJ++-- | Pretty print a 'Ppr' value on a single line with each block of+-- white space (newlines, tabs, etc.) converted to a single space, and+-- all the module qualifiers removed from the names. (If the data type+-- has no 'Name' values the friendlyNames function has no effect.)+pprint1 :: (Ppr a, Data a) => a -> [Char]+pprint1 = pprint1' . friendlyNames++pprint1' :: Ppr a => a -> [Char]+pprint1' = pprintStyle (HPJ.style {HPJ.mode = HPJ.OneLineMode})++-- | Pretty print with friendly names and wide lines+pprintW :: (Ppr a, Data a) => Int -> a -> [Char]+pprintW w = pprintW' w . friendlyNames++pprintW' :: Ppr a => Int -> a -> [Char]+pprintW' w = pprintStyle (HPJ.style {HPJ.lineLength = w})++-- | Helper function for pprint1 et. al.+pprintStyle :: Ppr a => HPJ.Style -> a -> String+pprintStyle style = HPJ.renderStyle style . to_HPJ_Doc . ppr++-- | Make a template haskell value more human reader friendly. The+-- result almost certainly won't be compilable. That's ok, though,+-- because the input is usually uncompilable - it imports hidden modules,+-- uses infix operators in invalid positions, puts module qualifiers in+-- places where they are not allowed, and maybe other things.+friendlyNames :: Data a => a -> a+friendlyNames =+ everywhere (mkT friendlyName)+ where+ friendlyName (Name x _) = Name x NameS -- Remove all module qualifiers++expandType :: DsMonad m => Type -> m Type+expandType typ = DS.typeToTH <$> (DS.dsType typ >>= DS.expand)++-- | Copied from haskell-src-meta+class ToName a where toName :: a -> Name++instance ToName TyVarBndr where+ toName (PlainTV n) = n+ toName (KindedTV n _) = n++instance ToName Con where+ toName (ForallC _ _ con) = toName con+ toName (NormalC cname _) = cname+ toName (RecC cname _) = cname+ toName (InfixC _ cname _) = cname++instance ToName VarStrictType where+ toName (n, _, _) = n++class HasMessageInfo a where+ verbosity' :: Lens' a Int+ prefix' :: Lens' a String++-- | Output a verbosity controlled error message with the current+-- indentation.+message :: (Quasi m, MonadReader s m, HasMessageInfo s) =>+ Int -> String -> m ()+message minv s = do+ v <- view verbosity'+ p <- view prefix'+ when (v >= minv) $ (runQ . runIO . putStr . indent p) s++-- | Indent the lines of a message.+indent :: String -> String -> String+indent p s = unlines $ fmap (p ++) (lines s)++decomposeType :: Type -> [Type]+decomposeType t0 = (go t0 [])+ where go (AppT t1 t2) ts = go t1 (t2 : ts)+ go t ts = t : ts++-- | Turn a type parameter list into type applications+composeType :: [Type] -> Type+composeType ts = foldl1 AppT ts++-- unfoldType :: Type -> (Type, [Type])+-- unfoldType t = go t []+-- where+-- go (AppT a p) ps = go a (p : ps)+-- go a ps = (a, ps)
− src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs
@@ -1,475 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}---- Hack for bug in older Cabal versions-#ifndef MIN_VERSION_template_haskell-#define MIN_VERSION_template_haskell(x,y,z) 1-#endif--module Language.Haskell.TH.TypeGraph.SafeCopyDerive where--import Language.Haskell.TH.TypeGraph.Phantom (nonPhantom)-import Data.Serialize (getWord8, putWord8, label)-import Data.SafeCopy--#if MIN_VERSION_template_haskell(2,8,0)-import Language.Haskell.TH hiding (Kind)-#else-import Language.Haskell.TH hiding (Kind(..))-#endif-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad-import Data.Maybe (fromMaybe)-#ifdef __HADDOCK__-import Data.Word (Word8) -- Haddock-#endif-import Data.Int (Int32)---- | FIXME - Bogus reimplementation of the hidden--- Data.SafeCopy.unVersion function-unVersion :: Version a -> Int32-unVersion v = read (takeWhile (/= '}') (drop 21 (show v)))---- | Derive an instance of 'SafeCopy'.------ When serializing, we put a 'Word8' describing the--- constructor (if the data type has more than one--- constructor). For each type used in the constructor, we--- call 'getSafePut' (which immediately serializes the version--- of the type). Then, for each field in the constructor, we--- use one of the put functions obtained in the last step.------ For example, given the data type and the declaration below------ @---data T0 b = T0 b Int---deriveSafeCopy 1 'base ''T0--- @------ we generate------ @---instance (SafeCopy a, SafeCopy b) =>--- SafeCopy (T0 b) where--- putCopy (T0 arg1 arg2) = contain $ do put_b <- getSafePut--- put_Int <- getSafePut--- put_b arg1--- put_Int arg2--- return ()--- getCopy = contain $ do get_b <- getSafeGet--- get_Int <- getSafeGet--- return T0 \<*\> get_b \<*\> get_Int--- version = 1--- kind = base--- @------ And, should we create another data type as a newer version of @T0@, such as------ @---data T a b = C a a | D b Int---deriveSafeCopy 2 'extension ''T------instance SafeCopy b => Migrate (T a b) where--- type MigrateFrom (T a b) = T0 b--- migrate (T0 b i) = D b i--- @------ we generate------ @---instance (SafeCopy a, SafeCopy b) =>--- SafeCopy (T a b) where--- putCopy (C arg1 arg2) = contain $ do putWord8 0--- put_a <- getSafePut--- put_a arg1--- put_a arg2--- return ()--- putCopy (D arg1 arg2) = contain $ do putWord8 1--- put_b <- getSafePut--- put_Int <- getSafePut--- put_b arg1--- put_Int arg2--- return ()--- getCopy = contain $ do tag <- getWord8--- case tag of--- 0 -> do get_a <- getSafeGet--- return C \<*\> get_a \<*\> get_a--- 1 -> do get_b <- getSafeGet--- get_Int <- getSafeGet--- return D \<*\> get_b \<*\> get_Int--- _ -> fail $ \"Could not identify tag \\\"\" ++--- show tag ++ \"\\\" for type Main.T \" ++--- \"that has only 2 constructors. \" ++--- \"Maybe your data is corrupted?\"--- version = 2--- kind = extension--- @------ Note that by using getSafePut, we saved 4 bytes in the case--- of the @C@ constructor. For @D@ and @T0@, we didn't save--- anything. The instance derived by this function always use--- at most the same space as those generated by--- 'deriveSafeCopySimple', but never more (as we don't call--- 'getSafePut'/'getSafeGet' for types that aren't needed).------ Note that you may use 'deriveSafeCopySimple' with one--- version of your data type and 'deriveSafeCopy' in another--- version without any problems.-deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec]-deriveSafeCopy = internalDeriveSafeCopy Normal--deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]-deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal---- | Derive an instance of 'SafeCopy'. The instance derived by--- this function is simpler than the one derived by--- 'deriveSafeCopy' in that we always use 'safePut' and--- 'safeGet' (instead of 'getSafePut' and 'getSafeGet').------ When serializing, we put a 'Word8' describing the--- constructor (if the data type has more than one constructor)--- and, for each field of the constructor, we use 'safePut'.------ For example, given the data type and the declaration below------ @---data T a b = C a a | D b Int---deriveSafeCopySimple 1 'base ''T--- @------ we generate------ @---instance (SafeCopy a, SafeCopy b) =>--- SafeCopy (T a b) where--- putCopy (C arg1 arg2) = contain $ do putWord8 0--- safePut arg1--- safePut arg2--- return ()--- putCopy (D arg1 arg2) = contain $ do putWord8 1--- safePut arg1--- safePut arg2--- return ()--- getCopy = contain $ do tag <- getWord8--- case tag of--- 0 -> do return C \<*\> safeGet \<*\> safeGet--- 1 -> do return D \<*\> safeGet \<*\> safeGet--- _ -> fail $ \"Could not identify tag \\\"\" ++--- show tag ++ \"\\\" for type Main.T \" ++--- \"that has only 2 constructors. \" ++--- \"Maybe your data is corrupted?\"--- version = 1--- kind = base--- @------ Using this simpler instance means that you may spend more--- bytes when serializing data. On the other hand, it is more--- straightforward and may match any other format you used in--- the past.------ Note that you may use 'deriveSafeCopy' with one version of--- your data type and 'deriveSafeCopySimple' in another version--- without any problems.-deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec]-deriveSafeCopySimple = internalDeriveSafeCopy Simple--deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]-deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple---- | Derive an instance of 'SafeCopy'. The instance derived by--- this function should be compatible with the instance derived--- by the module @Happstack.Data.SerializeTH@ of the--- @happstack-data@ package. The instances use only 'safePut'--- and 'safeGet' (as do the instances created by--- 'deriveSafeCopySimple'), but we also always write a 'Word8'--- tag, even if the data type isn't a sum type.------ For example, given the data type and the declaration below------ @---data T0 b = T0 b Int---deriveSafeCopy 1 'base ''T0--- @------ we generate------ @---instance (SafeCopy a, SafeCopy b) =>--- SafeCopy (T0 b) where--- putCopy (T0 arg1 arg2) = contain $ do putWord8 0--- safePut arg1--- safePut arg2--- return ()--- getCopy = contain $ do tag <- getWord8--- case tag of--- 0 -> do return T0 \<*\> safeGet \<*\> safeGet--- _ -> fail $ \"Could not identify tag \\\"\" ++--- show tag ++ \"\\\" for type Main.T0 \" ++--- \"that has only 1 constructors. \" ++--- \"Maybe your data is corrupted?\"--- version = 1--- kind = base--- @------ This instance always consumes at least the same space as--- 'deriveSafeCopy' or 'deriveSafeCopySimple', but may use more--- because of the useless tag. So we recomend using it only if--- you really need to read a previous version in this format,--- and not for newer versions.------ Note that you may use 'deriveSafeCopy' with one version of--- your data type and 'deriveSafeCopyHappstackData' in another version--- without any problems.-deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec]-deriveSafeCopyHappstackData = internalDeriveSafeCopy HappstackData--deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec]-deriveSafeCopyHappstackDataIndexedType = internalDeriveSafeCopyIndexedType HappstackData--data DeriveType = Normal | Simple | HappstackData--forceTag :: DeriveType -> Bool-forceTag HappstackData = True-forceTag _ = False--tyVarName :: TyVarBndr -> Name-tyVarName (PlainTV n) = n-#if MIN_VERSION_template_haskell(2,10,0)-tyVarName (KindedTV n _) = n-#endif--internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec]-internalDeriveSafeCopy deriveType versionId kindName tyName = do- info <- reify tyName- internalDeriveSafeCopy' deriveType versionId kindName tyName info--internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec]-internalDeriveSafeCopy' deriveType versionId kindName tyName info = do- case info of-#if MIN_VERSION_template_haskell(2,11,0)- TyConI (DataD context _name tyvars _kind cons _derivs)-#else- TyConI (DataD context _name tyvars cons _derivs)-#endif- | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++- ". The datatype must have less than 256 constructors."- | otherwise -> worker context tyvars (zip [0..] cons)--#if MIN_VERSION_template_haskell(2,11,0)- TyConI (NewtypeD context _name tyvars _kind con _derivs) ->-#else- TyConI (NewtypeD context _name tyvars con _derivs) ->-#endif- worker context tyvars [(0, con)]-- FamilyI _ insts -> do- decs <- forM insts $ \inst ->- case inst of-#if MIN_VERSION_template_haskell(2,11,0)- DataInstD context _name ty _kind cons _derivs ->-#else- DataInstD context _name ty cons _derivs ->-#endif- worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)--#if MIN_VERSION_template_haskell(2,11,0)- NewtypeInstD context _name ty _kind con _derivs ->-#else- NewtypeInstD context _name ty con _derivs ->-#endif- worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]- _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)- return $ concat decs- _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)- where- worker = worker' (conT tyName)- worker' tyBase context tyvars cons =- nonPhantom tyName >>= \tyvars' ->- let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0)- safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif- in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ var] | VarT var <- tyvars'] ++ map return context ++ migrateFromKind ty kindName)- (conT ''SafeCopy `appT` ty)- [ mkPutCopy deriveType cons- , mkGetCopy deriveType (show tyName) cons- , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []- , valD (varP 'kind) (normalB (varE kindName)) []- , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []]- ]- -- This adds Migrate Foo to the superclasses of SafeCopy Foo if- -- the kind is extension. This lets us defer the actual- -- implementation of the Migrate instance, which is harmless and- -- sometimes useful.- migrateFromKind ty name =- if name == 'extension then [appT (conT ''Migrate) ty] else []--internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec]-internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do- info <- reify tyName- internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info--internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec]-internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info = do- tyIndex <- mapM conT tyIndex'- case info of- FamilyI _ insts -> do- decs <- forM insts $ \inst ->- case inst of-#if MIN_VERSION_template_haskell(2,11,0)- DataInstD context _name ty _kind cons _derivs-#else- DataInstD context _name ty cons _derivs-#endif- | ty == tyIndex ->- worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)- | otherwise ->- return []--#if MIN_VERSION_template_haskell(2,11,0)- NewtypeInstD context _name ty _kind con _derivs-#else- NewtypeInstD context _name ty con _derivs-#endif- | ty == tyIndex ->- worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]- | otherwise ->- return []- _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)- return $ concat decs- _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)- where- typeNameStr = unwords $ map show (tyName:tyIndex')- worker' tyBase context tyvars cons =- let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]-#if MIN_VERSION_template_haskell(2,10,0)- safeCopyClass args = foldl appT (conT ''SafeCopy) args-#else- safeCopyClass args = classP ''SafeCopy args-#endif- in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)- (conT ''SafeCopy `appT` ty)- [ mkPutCopy deriveType cons- , mkGetCopy deriveType typeNameStr cons- , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []- , valD (varP 'kind) (normalB (varE kindName)) []- , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []]- ]--mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ-mkPutCopy deriveType cons = funD 'putCopy $ map mkPutClause cons- where- manyConstructors = length cons > 1 || forceTag deriveType- mkPutClause (conNumber, con)- = do putVars <- mapM (\n -> newName ("a" ++ show n)) [1..conSize con]- (putFunsDecs, putFuns) <- case deriveType of- Normal -> mkSafeFunctions "safePut_" 'getSafePut con- _ -> return ([], const 'safePut)- let putClause = conP (conName con) (map varP putVars)- putCopyBody = varE 'contain `appE` doE (- [ noBindS $ varE 'putWord8 `appE` litE (IntegerL conNumber) | manyConstructors ] ++- putFunsDecs ++- [ noBindS $ varE (putFuns typ) `appE` varE var | (typ, var) <- zip (conTypes con) putVars ] ++- [ noBindS $ varE 'return `appE` tupE [] ])- clause [putClause] (normalB putCopyBody) []--mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ-mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) []- where- mkLabel = varE 'label `appE` litE (stringL labelString) `appE` getCopyBody- labelString = tyName ++ ":"- getCopyBody- = case cons of- [(_, con)] | not (forceTag deriveType) -> mkGetBody con- _ -> do- tagVar <- newName "tag"- doE [ bindS (varP tagVar) (varE 'getWord8)- , noBindS $ caseE (varE tagVar) (- [ match (litP $ IntegerL i) (normalB $ mkGetBody con) [] | (i, con) <- cons ] ++- [ match wildP (normalB $ varE 'fail `appE` errorMsg tagVar) [] ]) ]- mkGetBody con- = do (getFunsDecs, getFuns) <- case deriveType of- Normal -> mkSafeFunctions "safeGet_" 'getSafeGet con- _ -> return ([], const 'safeGet)- let getBase = appE (varE 'return) (conE (conName con))- getArgs = foldl (\a t -> infixE (Just a) (varE '(<*>)) (Just (varE (getFuns t)))) getBase (conTypes con)- doE (getFunsDecs ++ [noBindS getArgs])- errorMsg tagVar = infixE (Just $ strE str1) (varE '(++)) $ Just $- infixE (Just tagStr) (varE '(++)) (Just $ strE str2)- where- strE = litE . StringL- tagStr = varE 'show `appE` varE tagVar- str1 = "Could not identify tag \""- str2 = concat [ "\" for type "- , show tyName- , " that has only "- , show (length cons)- , " constructors. Maybe your data is corrupted?" ]--mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Type -> Name)-mkSafeFunctions name baseFun con = do let origTypes = conTypes con- realTypes <- mapM followSynonyms origTypes- finish (zip origTypes realTypes) <$> foldM go ([], []) realTypes- where go (ds, fs) t- | found = return (ds, fs)- | otherwise = do funVar <- newName (name ++ typeName t)- return ( bindS (varP funVar) (varE baseFun) : ds- , (t, funVar) : fs )- where found = any ((== t) . fst) fs- finish- :: [(Type, Type)] -- "dictionary" from synonyms(or not) to real types- -> ([StmtQ], [(Type, Name)]) -- statements- -> ([StmtQ], Type -> Name) -- function body and name-generator- finish typeList (ds, fs) = (reverse ds, getName)- where getName typ = fromMaybe err $ lookup typ typeList >>= flip lookup fs- err = error "mkSafeFunctions: never here"---- | Follow type synonyms. This allows us to see, for example,--- that @[Char]@ and @String@ are the same type and we just need--- to call 'getSafePut' or 'getSafeGet' once for both.-followSynonyms :: Type -> Q Type-followSynonyms t@(ConT name)- = maybe (return t) followSynonyms =<<- recover (return Nothing) (do info <- reify name- return $ case info of- TyVarI _ ty -> Just ty- TyConI (TySynD _ _ ty) -> Just ty- _ -> Nothing)-followSynonyms (AppT ty1 ty2) = liftM2 AppT (followSynonyms ty1) (followSynonyms ty2)-followSynonyms (SigT ty k) = liftM (flip SigT k) (followSynonyms ty)-followSynonyms t = return t--conSize :: Con -> Int-conSize (NormalC _name args) = length args-conSize (RecC _name recs) = length recs-conSize InfixC{} = 2-conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it."-#if MIN_VERSION_template_haskell(2,11,0)-conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."-conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it."-#endif--conName :: Con -> Name-conName (NormalC name _args) = name-conName (RecC name _recs) = name-conName (InfixC _ name _) = name-conName _ = error "conName: never here"--conTypes :: Con -> [Type]-conTypes (NormalC _name args) = [t | (_, t) <- args]-conTypes (RecC _name args) = [t | (_, _, t) <- args]-conTypes (InfixC (_, t1) _ (_, t2)) = [t1, t2]-conTypes _ = error "conName: never here"--typeName :: Type -> String-typeName (VarT name) = nameBase name-typeName (ConT name) = nameBase name-typeName (TupleT n) = "Tuple" ++ show n-typeName ArrowT = "Arrow"-typeName ListT = "List"-typeName (AppT t u) = typeName t ++ typeName u-typeName (SigT t _k) = typeName t-typeName _ = "_"
+ src/Language/Haskell/TH/TypeGraph/Serialize.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Language.Haskell.TH.TypeGraph.Serialize+ ( deriveSerialize+ ) where++import Language.Haskell.TH++import Data.Serialize+import Data.Set (toList)+import Language.Haskell.TH (Loc, location)+import Language.Haskell.TH.Lift (lift)+import Language.Haskell.TH.TypeGraph.Constraints (deriveConstraints, withBindings)+import Language.Haskell.TH.TypeGraph.Prelude (toName)++deriveSerialize :: TypeQ -> Q [Dec]+deriveSerialize typq = location >>= \loc -> typq >>= \typ -> deriveSerialize' loc typ++deriveSerialize' :: Loc -> Type -> Q [Dec]+deriveSerialize' loc typ0 = do+ (: []) <$> goApply typ0 (decompose typ0)+ where+ goApply :: Type -> [Type] -> Q Dec+ goApply typ0 (ConT tname : vals) =+ reify tname >>= goInfo typ0 tname vals+ goApply typ0 (typ : _vals) =+ error (pprint loc ++ ": deriveSerialize - unexpected type " ++ show typ ++ " (in " ++ show typ0 ++ ")")++ goInfo :: Type -> Name -> [Type] -> Info -> Q Dec+ goInfo typ0 _tname vals (TyConI (TySynD _ vars typ)) =+ withBindings vars vals (\unbound subst -> goApply typ0 (decompose (subst typ) ++ vals))+#if MIN_VERSION_template_haskell(2,11,0)+ goInfo _typ0 tname vals (TyConI (DataD _ _ vars _ cons _)) =+#else+ goInfo _typ0 tname vals (TyConI (DataD _ _ vars cons _)) =+#endif+ withBindings vars vals (\unbound subst -> goClauses tname vals vars cons subst)+#if MIN_VERSION_template_haskell(2,11,0)+ goInfo _typ0 tname vals (TyConI (NewtypeD _ _ vars _ con _)) =+#else+ goInfo _typ0 tname vals (TyConI (NewtypeD _ _ vars con _)) =+#endif+ withBindings vars vals (\unbound subst -> goClauses tname vals vars [con] subst)+#if MIN_VERSION_template_haskell(2,11,0)+ goInfo _typ0 tname vals (FamilyI (DataFamilyD famname vars _mk) _insts) =+#else+ goInfo _typ0 tname vals (FamilyI (FamilyD DataFam famname vars _mk) _insts) =+#endif+ withBindings vars vals+ (\unbound subst -> do+ insts <- reifyInstances famname (map subst (map (VarT . toName) vars ++ unbound))+ case insts of+#if MIN_VERSION_template_haskell(2,11,0)+ [DataInstD _ _famname vals' _ cons _] ->+#else+ [DataInstD _ _famname vals' cons _] ->+#endif+ goClauses tname vals' vars cons subst+ [] ->+ let typ = subst (compose (ConT famname : fmap (VarT . toName) vars)) in+ error $ pprint loc ++ ": deriveSerialize " ++ pprint typ0 ++ "\n Data family instance could not be reified: " ++ pprint typ)+ goInfo _typ0 _tname _vals info =+ error $ pprint loc ++ ": deriveSerialize " ++ pprint typ0 ++ "\n unexpected info: " ++ show info++ goClauses :: Name -> [Type] -> [TyVarBndr] -> [Con] -> (Type -> Type) -> Q Dec+ goClauses tname vals vars cons subst = do+ let -- Extend the value list to ensure the resulting type is monomorphic+ vals' = map subst vals ++ map (VarT . toName) (drop (length vals) vars)+ putFun = funD 'put (map (\(tag, con) -> do+ (conName, fnames) <- conInfo con+ clause [conPat fnames (tag, con)]+ (normalB (conExp cons tag conName fnames))+ []) (zip [0..] cons))+ getFun = funD 'get [clause [] (normalB (case cons of+ [con] -> conGet' con+ _ -> [|getWord8 >>= \i -> $(caseE [|i|]+ (map conMatch (zip [0..] cons) +++ [newName "n" >>= \n -> match (varP n) (normalB [|error $ pprint loc ++ ": deriveSerialize - unexpected tag " ++ show $(varE n) +++ " decoding " ++ show tname ++ " (expected 0.." ++ show (length cons) ++ ")"|]) []]))|])) []]+ constraints <- toList <$> deriveConstraints 0 ''Serialize tname vals'+ instanceD+ (pure constraints)+ (appT (conT ''Serialize) (foldl1 appT (conT tname : map pure vals')))+ [putFun, getFun]+ conPat fnames (_, NormalC name _) = conP name (map varP fnames)+ conPat fnames (_, RecC name _) = conP name (map varP fnames)+ conPat fnames (_, InfixC _ name _) = conP name (map varP fnames)+ conPat fnames (tag, ForallC _ _ con) = conPat fnames (tag, con)++ conExp :: [Con] -> Int -> Name -> [Name] -> ExpQ+ conExp cons tag cname fnames =+ doSeq $ (if length cons > 1 then [ [|putWord8 $(lift tag)|] ] else []) +++ map (\fname -> [|put $(varE fname)|]) fnames+ conMatch :: (Int, Con) -> MatchQ+ conMatch (n, con) = match (litP (integerL (fromIntegral n))) (normalB $ conGet' con) []++ conGet' :: Con -> ExpQ+ conGet' (ForallC _ _ con) = conGet' con+ conGet' (NormalC name sts) = conGet name (length sts)+ conGet' (RecC name vsts) = conGet name (length vsts)+ conGet' (InfixC lhs name rhs) = conGet name 2++ conGet :: Name -> Int -> ExpQ+ conGet name arity = doApp ([|pure $(conE name)|] : replicate arity [|get|])++ doSeq es = foldl1 (\e1 e2 -> [|$e1 >> $e2|]) es+ doApp es = foldl1 (\e1 e2 -> [|$e1 <*> $e2|]) es++ conInfo (NormalC name sts) = (name,) <$> mapM (\(_, n) -> newName ("a" ++ show n)) (zip sts ([1..] :: [Int]))+ conInfo (RecC name vsts) = (name,) <$> mapM (\(_, n) -> newName ("a" ++ show n)) (zip vsts ([1..] :: [Int]))+ conInfo (InfixC lhs name rhs) = (name,) <$> mapM (\n -> newName ("a" ++ show n)) ([1, 2] :: [Int])+ conInfo (ForallC _ _ con) = conInfo con++decompose :: Type -> [Type]+decompose t0 = go t0 []+ where go (AppT t1 t2) ts = go t1 (t2 : ts)+ go t ts = t : ts++compose :: [Type] -> Type+compose types = foldl1 AppT types++data Sample alpha = First+ | Second alpha alpha+ | Third alpha++instance Serialize a => Serialize (Sample a)+ where put (First) = putWord8 0+ put (Second a1_0 a2_1) = putWord8 1 >> (put a1_0 >> put a2_1)+ put (Third a1_2) = putWord8 2 >> put a1_2+ get = getWord8 >>= (\i_3 -> case i_3 of+ 0 -> pure First+ 1 -> (pure Second <*> get) <*> get+ 2 -> pure Third <*> get)++-- test = putStrLn $(deriveSerialize [t|Sample|] >>= lift . pprint)
src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs view
@@ -20,47 +20,25 @@ , withBindings , HasTypeTraversal(..) , doApply- , FieldInfo(..)- , expandType, pprint1, pprint1', pprintW, pprintW'- , ToName(toName)- , HasMessageInfo(..), message, indent ) where -import Control.Lens (Lens', view) import Control.Monad.RWS as Monad hiding (lift) import Data.Generics (Data, everywhere, mkT) import Data.List (intercalate) import Data.Map.Strict as Map (Map, lookup) import qualified Data.Map.Strict as Map (fromList)--- import Debug.Trace import Instances.TH.Lift () import Language.Haskell.TH hiding (prim)-import Language.Haskell.TH.Desugar as DS (DsMonad, typeToTH, dsType, expand)-import Language.Haskell.TH.PprLib (to_HPJ_Doc)+import Language.Haskell.TH.Desugar as DS (DsMonad) import Language.Haskell.TH.Syntax as TH import Language.Haskell.TH.TypeGraph.Orphans ()-import qualified Text.PrettyPrint as HPJ+import Language.Haskell.TH.TypeGraph.Prelude (expandType, pprint1, toName) class Monad m => HasTypeParameters m where pushParam :: Type -> m a -> m a -- ^ Push a parameter withParams :: ([Type] -> m ()) -> m () -data FieldInfo- = FieldInfo- { _typeName :: Name- , _constrCount :: Int- , _constrIndex :: Int- , _constrName :: Name- , _fieldCount :: Int- , _fieldIndex :: Int- , _fieldName :: Maybe Name- , _fieldType :: Type- } deriving Show- class (DsMonad m, HasVisitedMap m) => HasTypeTraversal m where- prepType :: Type -> m Type- -- ^ Normally just 'return', this can modify the types during the- -- traversal. doTypeInternal :: Type -> m () -- ^ This is passed every type that is encountered. The methods -- below are called from doApply.@@ -71,15 +49,15 @@ -- ^ When a TupleT type is encountered this is called once for -- each element, with the type, element type, and element -- position.- doField :: Type -> (Type -> Type) -> FieldInfo -> m ()+ doField :: Type -> Name -> (Int, Int) -> Name -> (Int, Int) -> Maybe Name -> Type -> m () -- ^ When a field is encountered this is called with all the -- field info - type name, constructor count/position/name, -- field count/position/type/maybe name.- doVarT :: Type -> Name -> m ()- -- ^ Called when a type variable is encountered.+ doVarT :: Type -> Type -> m ()+ -- ^ Called when a type variable or type function is encountered. doType :: HasTypeTraversal m => Type -> m ()-doType typ = prepType typ >>= doTypeOnce doTypeInternal+doType typ = doTypeOnce doTypeInternal typ class DsMonad m => HasVisitedMap m where unvisited :: Type -> m () -> m () -- ^ Perform action if type has not been visted@@ -89,7 +67,7 @@ doApply :: (HasTypeTraversal m, HasTypeParameters m, DsMonad m) => Type -> Type -> m () doApply typ0 (ForallT _tvs _cxt typ) = doApply typ0 typ-doApply typ0 (VarT name) = doVarT typ0 name+doApply typ0 (VarT name) = doVarT typ0 (VarT name) doApply typ0 (AppT a b) = pushParam b (doApply typ0 a) doApply typ0 (ConT tname) = qReify tname >>= doInfo typ0 doApply typ0 ListT = do@@ -111,57 +89,32 @@ doInfo _typ0 (TyConI (TySynD _tname binds typ)) = runQ (expandType typ) >>= \typ' -> withBindings (\subst -> doType (subst typ')) binds-#if MIN_VERSION_template_haskell(2,11,0)-doInfo typ0 (TyConI (NewtypeD cx tname binds mk con supers)) =- doInfo typ0 (TyConI (DataD cx tname binds mk [con] supers))-doInfo typ0 (TyConI (DataD _ tname binds _mk cons _supers)) =- withBindings (\subst -> do mapM_ (uncurry (doCon typ0 tname subst (length cons))) (zip [1..] cons)) binds-#else-doInfo typ0 (TyConI (NewtypeD cx tname binds con supers)) =- doInfo typ0 (TyConI (DataD cx tname binds [con] supers))-doInfo typ0 (TyConI (DataD _ tname binds cons _supers)) =- withBindings (\subst -> do mapM_ (uncurry (doCon typ0 tname subst (length cons))) (zip [1..] cons)) binds-#endif+doInfo typ0 (TyConI dec) =+ let (tname, binds, cons) = decInfo dec in+ withBindings (\subst -> do mapM_ (uncurry (doCon typ0 tname subst)) (zip (fmap (,(length cons)) [1..]) cons)) binds+-- Encountered a declaration like data family (ProxyType t). Call+-- doVarT on the assumption that ProxyType t is a concrete type. I'm+-- not sure if this is the best possible implementation, but its+-- better than what we have now.+doInfo typ0 (FamilyI dec _insts) =+ let (tname, binds) = famInfo dec in+ withBindings (\subst -> doVarT typ0 (subst (foldl AppT (ConT tname) (fmap (VarT . toName) binds)))) binds doInfo _ info = error $ "Unexpected info: " ++ pprint1 info ++ "\n\t" ++ show info -doCon :: (HasTypeParameters m, HasTypeTraversal m) => Type -> Name -> (Type -> Type) -> Int -> Int -> Con -> m ()-doCon typ0 tname subst cct cpos (ForallC _ _ con) = doCon typ0 tname subst cct cpos con-doCon typ0 tname subst cct cpos (RecC cname vsts) =- mapM_ (\(i, (fname, _, ftype)) ->+doCon :: (HasTypeParameters m, HasTypeTraversal m) => Type -> Name -> (Type -> Type) -> (Int, Int) -> Con -> m ()+doCon typ0 tname subst (cpos, cct) (ForallC _ _ con) = doCon typ0 tname subst (cpos, cct) con+doCon typ0 tname subst (cpos, cct) (RecC cname vsts) =+ mapM_ (\(fpos, (fname, _, ftype)) -> expandType ftype >>= \ftype' ->- let fld = FieldInfo { _typeName = tname- , _constrCount = cct- , _constrIndex = cpos- , _constrName = cname- , _fieldCount = length vsts- , _fieldIndex = i- , _fieldName = Just fname- , _fieldType = subst ftype' } in- doField typ0 subst fld) (zip [1..] vsts)-doCon typ0 tname subst cct cpos (NormalC cname sts) =- mapM_ (\(i, (_, ftype)) ->+ doField typ0 tname (cpos, cct) cname (fpos, length vsts) (Just fname) (subst ftype')) (zip [1..] vsts)+doCon typ0 tname subst (cpos, cct) (NormalC cname sts) =+ mapM_ (\(fpos, (_, ftype)) -> expandType ftype >>= \ftype' ->- let fld = FieldInfo { _typeName = tname- , _constrCount = cct- , _constrIndex = cpos- , _constrName = cname- , _fieldCount = length sts- , _fieldIndex = i- , _fieldName = Nothing- , _fieldType = subst ftype' } in- doField typ0 subst fld) (zip [1..] sts)-doCon typ0 tname subst cct cpos (InfixC lhs cname rhs) =- mapM_ (\(i, (_, ftype)) ->+ doField typ0 tname (cpos, cct) cname (fpos, length sts) Nothing (subst ftype')) (zip [1..] sts)+doCon typ0 tname subst (cpos, cct) (InfixC lhs cname rhs) =+ mapM_ (\(fpos, (_, ftype)) -> expandType ftype >>= \ftype' ->- let fld = FieldInfo { _typeName = tname- , _constrCount = cct- , _constrIndex = cpos- , _constrName = cname- , _fieldCount = 2- , _fieldIndex = i- , _fieldName = Nothing- , _fieldType = subst ftype' } in- doField typ0 subst fld) [(1, lhs), (2, rhs)]+ doField typ0 tname (cpos, cct) cname (fpos, 2) Nothing (subst ftype')) [(1, lhs), (2, rhs)] -- | Input is a list of type variable bindings (such as those -- appearing in a Dec) and the current stack of type parameters@@ -185,70 +138,20 @@ subst1 bindings t@(VarT name) = maybe t id (Map.lookup name bindings) subst1 _ t = t --- | Pretty print a 'Ppr' value on a single line with each block of--- white space (newlines, tabs, etc.) converted to a single space, and--- all the module qualifiers removed from the names. (If the data type--- has no 'Name' values the friendlyNames function has no effect.)-pprint1 :: (Ppr a, Data a) => a -> [Char]-pprint1 = pprint1' . friendlyNames--pprint1' :: Ppr a => a -> [Char]-pprint1' = pprintStyle (HPJ.style {HPJ.mode = HPJ.OneLineMode})---- | Pretty print with friendly names and wide lines-pprintW :: (Ppr a, Data a) => Int -> a -> [Char]-pprintW w = pprintW' w . friendlyNames--pprintW' :: Ppr a => Int -> a -> [Char]-pprintW' w = pprintStyle (HPJ.style {HPJ.lineLength = w})---- | Helper function for pprint1 et. al.-pprintStyle :: Ppr a => HPJ.Style -> a -> String-pprintStyle style = HPJ.renderStyle style . to_HPJ_Doc . ppr---- | Make a template haskell value more human reader friendly. The--- result almost certainly won't be compilable. That's ok, though,--- because the input is usually uncompilable - it imports hidden modules,--- uses infix operators in invalid positions, puts module qualifiers in--- places where they are not allowed, and maybe other things.-friendlyNames :: Data a => a -> a-friendlyNames =- everywhere (mkT friendlyName)- where- friendlyName (Name x _) = Name x NameS -- Remove all module qualifiers--expandType :: DsMonad m => Type -> m Type-expandType typ = DS.typeToTH <$> (DS.dsType typ >>= DS.expand)---- | Copied from haskell-src-meta-class ToName a where toName :: a -> Name--instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n--instance ToName Con where- toName (ForallC _ _ con) = toName con- toName (NormalC cname _) = cname- toName (RecC cname _) = cname- toName (InfixC _ cname _) = cname--instance ToName VarStrictType where- toName (n, _, _) = n--class HasMessageInfo a where- verbosity' :: Lens' a Int- prefix' :: Lens' a String---- | Output a verbosity controlled error message with the current--- indentation.-message :: (Quasi m, MonadReader s m, HasMessageInfo s) =>- Int -> String -> m ()-message minv s = do- v <- view verbosity'- p <- view prefix'- when (v >= minv) $ (runQ . runIO . putStr . indent p) s+decInfo :: Dec -> (Name, [TyVarBndr], [Con])+#if MIN_VERSION_template_haskell(2,11,0)+decInfo (NewtypeD _ tname binds _mk con _supers) = (tname, binds, [con])+decInfo (DataD _ tname binds _mk cons _supers) = (tname, binds, cons)+#else+decInfo (NewtypeD _cx tname binds con _supers) = (tname, binds, [con])+decInfo (DataD _ tname binds cons _supers) = (tname, binds, cons)+#endif+decInfo _ = error "decInfo" --- | Indent the lines of a message.-indent :: String -> String -> String-indent p s = unlines $ fmap (p ++) (lines s)+famInfo :: Dec -> (Name, [TyVarBndr])+#if MIN_VERSION_template_haskell(2,11,0)+famInfo (DataFamilyD typ binds _mk) = (typ, binds)+#else+famInfo (FamilyD DataFam typ binds _mk) = (typ, binds)+#endif+famInfo _ = error "famInfo"
src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs view
@@ -1,6 +1,6 @@ -- | Modified version of Web.Routes.TH -{-# LANGUAGE CPP, TemplateHaskell #-}+{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} module Language.Haskell.TH.TypeGraph.WebRoutesTH ( derivePathInfo , derivePathInfo'@@ -13,11 +13,13 @@ import Data.Char (isUpper, toLower, toUpper) import Data.List (intercalate, foldl') import Data.List.Split (split, dropInitBlank, keepDelimsL, whenElt)+import Data.Set (toList) import Data.Text (pack, unpack)-import Debug.Trace+--import Debug.Trace import Language.Haskell.TH import Language.Haskell.TH.Syntax (nameBase)-import Language.Haskell.TH.TypeGraph.Phantom (nonPhantom)+import Language.Haskell.TH.TypeGraph.Constraints (deriveConstraints, withBindings, compose, decompose)+import Language.Haskell.TH.TypeGraph.Prelude (toName) import Text.ParserCombinators.Parsec ((<|>),many1) import Web.Routes.PathInfo @@ -26,9 +28,9 @@ -- > $(derivePathInfo ''SiteURL) -- -- Uses the 'standard' formatter by default.-derivePathInfo :: Name+derivePathInfo :: TypeQ -> Q [Dec]-derivePathInfo = derivePathInfo' standard+derivePathInfo typq = typq >>= derivePathInfo' standard . decompose -- FIXME: handle when called with a type (not data, newtype) @@ -45,22 +47,22 @@ -- -- see also: 'standard' derivePathInfo' :: (String -> String)- -> Name+ -> [Type] -> Q [Dec]-derivePathInfo' formatter name- = do c <- parseInfo name+derivePathInfo' formatter (ConT name : params)+ = do c <- parseInfo name params case c of Tagged cons cx keys ->- do keys' <- nonPhantom name- -- trace ("nonPhantom " ++ show name ++ " -> " ++ show keys') (pure ())- let context = [ mkCtx ''PathInfo [pure key] | key <- keys' ] ++ map return cx- i <- instanceD (sequence context) (mkType ''PathInfo [mkType name (map varT keys)])+ do context <- toList <$> deriveConstraints 0 ''PathInfo name params+ -- trace ("derivePathInfo - constraints " ++ show name ++ " -> " ++ pprint context) (pure ())+ -- let context = [ mkCtx ''PathInfo [pure key] | key <- keys' ] ++ map return cx+ i <- instanceD (pure context) (mkType ''PathInfo [mkType name (map pure keys)]) [ toPathSegmentsFn cons , fromPathSegmentsFn cons ] return [i] where-#if MIN_VERSION_template_haskell(2,4,0)+#if !MIN_VERSION_template_haskell(2,4,0) mkCtx = classP #else mkCtx = mkType@@ -92,21 +94,39 @@ mkType :: Name -> [TypeQ] -> TypeQ mkType con = foldl appT (conT con) -data Class = Tagged [(Name, Int)] Cxt [Name]+data Class = Tagged [(Name, Int)] Cxt [Type] -parseInfo :: Name -> Q Class-parseInfo name- = do info <- reify name- case info of+parseInfo :: Name -> [Type] -> Q Class+parseInfo name vals+ = reify name >>= doInfo+ where doInfo (TyConI dec) = doDec dec+ doInfo (FamilyI dec insts) = doDec dec+ doInfo info = error $ "derivePathInfo - invalid input: " ++ show info #if MIN_VERSION_template_haskell(2,11,0)- TyConI (DataD cx _ keys _ cs _) -> return $ Tagged (map conInfo cs) cx $ map conv keys- TyConI (NewtypeD cx _ keys _ con _)-> return $ Tagged [conInfo con] cx $ map conv keys+ doDec (DataD cx _ keys _ cs _) = return $ Tagged (map conInfo cs) cx $ map (VarT . toName) keys+ doDec (NewtypeD cx _ keys _ con _) = return $ Tagged [conInfo con] cx $ map (VarT . toName) keys+ doDec (DataFamilyD fname keys _) =+ withBindings keys vals+ (\unbound subst -> do+ insts <- reifyInstances fname (map subst (map (VarT . toName) keys ++ unbound))+ case insts of+ [DataInstD cx _fname vals' _ cs _] ->+ return $ Tagged (map conInfo cs) cx $ map (subst . VarT . toName) keys+ [] -> error $ "derivePathInfo - data family instance " ++ show fname ++ " could not be reified:\n " ++ pprint (compose (ConT name : vals))) #else- TyConI (DataD cx _ keys cs _) -> return $ Tagged (map conInfo cs) cx $ map conv keys- TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx $ map conv keys+ doDec (DataD cx _ keys cs _) = return $ Tagged (map conInfo cs) cx $ map (VarT . toName) keys+ doDec (NewtypeD cx _ keys con _) = return $ Tagged [conInfo con] cx $ map (VarT . toName) keys+ doDec (FamilyD DataFam fname keys _) =+ withBindings keys vals+ (\unbound subst -> do+ insts <- reifyInstances fname (map subst (map (VarT . toName) keys ++ unbound))+ case insts of+ [DataInstD cx _fname vals' cs _] ->+ return $ Tagged (map conInfo cs) cx $ map subst (map (VarT . toName) keys ++ unbound)+ [] -> error $ "derivePathInfo - data family instance " ++ show fname ++ " could not be reified:\n " ++ pprint (compose (ConT name : vals))) #endif- _ -> error $ "derivePathInfo - invalid input: " ++ pprint info- where conInfo (NormalC n args) = (n, length args)+ doDec dec = error $ "derivePathInfo - invalid input: " ++ show dec+ conInfo (NormalC n args) = (n, length args) conInfo (RecC n args) = (n, length args) conInfo (InfixC _ n _) = (n, 2) conInfo (ForallC _ _ con) = conInfo con@@ -130,7 +150,7 @@ mkRoute :: Name -> Q [Dec] mkRoute url =- do (Tagged cons _ _) <- parseInfo url+ do (Tagged cons _ _) <- parseInfo url [] fn <- funD (mkName "route") $ map (\(con, numArgs) -> do -- methods <- parseMethods con
+ test/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++import Language.Haskell.TH.Lift (lift)+import Language.Haskell.TH.TypeGraph.Constraints (monomorphize)+import Language.Haskell.TH.TypeGraph.Serialize (deriveSerialize)+import Language.Haskell.TH.TypeGraph.Prelude (pprint1)+import Language.Haskell.TH.TypeGraph.WebRoutesTH (derivePathInfo)+import Prelude hiding (concat)+import Test.HUnit++import Types++default (String)++-- The deriveJSON function provided by aeson puts constraints ToJSON+-- t, ToJSON s, ToJSON a on the instances. The ToJSON t constraint is+-- unnecessary because it doesn't actually appear in the value, and we+-- need constraints ToJSON (KeyType t) but they are omitted.++-- $(deriveJSON defaultOptions ''Hop)+-- $(deriveJSON defaultOptions ''TraversalPath)++++tests :: Test+tests = do+ TestList+ [ TestCase+ (assertEqual "deriveSerialize Hop"+ ("instance Serialize key => Serialize (Hop key) where put (NamedField a1 a2 a3 a4 a5 a6 a7) = ((((((putWord8 0 >> put a1) >> put a2) >> put a3) >> put a4) >> put a5) >> put a6) >> put a7 put (AnonField a1 a2 a3 a4 a5 a6) = (((((putWord8 1 >> put a1) >> put a2) >> put a3) >> put a4) >> put a5) >> put a6 put (TupleHop a1) = putWord8 2 >> put a1 put (IndexHop a1) = putWord8 3 >> put a1 put (ViewHop) = putWord8 4 put (IxViewHop a1) = putWord8 5 >> put a1 get = getWord8 >>= (\\i -> case i of 0 -> ((((((pure NamedField <*> get) <*> get) <*> get) <*> get) <*> get) <*> get) <*> get 1 -> (((((pure AnonField <*> get) <*> get) <*> get) <*> get) <*> get) <*> get 2 -> pure TupleHop <*> get 3 -> pure IndexHop <*> get 4 -> pure ViewHop 5 -> pure IxViewHop <*> get n -> error $ (\"deriveSerialize - unexpected tag: \" ++ show n))" :: String)+ $(deriveSerialize [t|Hop|] >>= lift . pprint1))+ , TestCase (assertEqual "deriveSerialize TraversalPath"+ ("instance (Serialize (KeyType t), Serialize (ProxyType t)) => Serialize (TraversalPath t s a) where put (TraversalPath a1 a2 a3) = (put a1 >> put a2) >> put a3 get = ((pure TraversalPath <*> get) <*> get) <*> get" :: String)+ $(deriveSerialize [t|TraversalPath|] >>= lift . pprint1))+ , TestCase+ (assertEqual "deriveSerialize (ValueType TestPaths)"+ ("instance Serialize (ValueType TestPaths) where put (V_Eitherz20UURIz20UInteger a1) = putWord8 0 >> put a1 put (V_Int a1) = putWord8 1 >> put a1 put (V_Integer a1) = putWord8 2 >> put a1 put (V_Loc a1) = putWord8 3 >> put a1 put (V_Maybez20UURIAuth a1) = putWord8 4 >> put a1 put (V_Maybez20UZLEitherz20UURIz20UIntegerZR a1) = putWord8 5 >> put a1 put (V_Name a1) = putWord8 6 >> put a1 put (V_TyLit a1) = putWord8 7 >> put a1 put (V_TyVarBndr a1) = putWord8 8 >> put a1 put (V_Type a1) = putWord8 9 >> put a1 put (V_URI a1) = putWord8 10 >> put a1 put (V_URIAuth a1) = putWord8 11 >> put a1 put (V_ZLIntz2cUz20UIntZR a1) = putWord8 12 >> put a1 put (V_ZLIntz2cUz20UTyVarBndrZR a1) = putWord8 13 >> put a1 put (V_ZLIntz2cUz20UTypeZR a1) = putWord8 14 >> put a1 put (V_ZLIntz2cUz20UZMCharZNZR a1) = putWord8 15 >> put a1 put (V_ZMCharZN a1) = putWord8 16 >> put a1 put (V_ZMIntZN a1) = putWord8 17 >> put a1 put (V_ZMTyVarBndrZN a1) = putWord8 18 >> put a1 put (V_ZMTypeZN a1) = putWord8 19 >> put a1 put (V_ZMZMCharZNZN a1) = putWord8 20 >> put a1 get = getWord8 >>= (\\i -> case i of 0 -> pure V_Eitherz20UURIz20UInteger <*> get 1 -> pure V_Int <*> get 2 -> pure V_Integer <*> get 3 -> pure V_Loc <*> get 4 -> pure V_Maybez20UURIAuth <*> get 5 -> pure V_Maybez20UZLEitherz20UURIz20UIntegerZR <*> get 6 -> pure V_Name <*> get 7 -> pure V_TyLit <*> get 8 -> pure V_TyVarBndr <*> get 9 -> pure V_Type <*> get 10 -> pure V_URI <*> get 11 -> pure V_URIAuth <*> get 12 -> pure V_ZLIntz2cUz20UIntZR <*> get 13 -> pure V_ZLIntz2cUz20UTyVarBndrZR <*> get 14 -> pure V_ZLIntz2cUz20UTypeZR <*> get 15 -> pure V_ZLIntz2cUz20UZMCharZNZR <*> get 16 -> pure V_ZMCharZN <*> get 17 -> pure V_ZMIntZN <*> get 18 -> pure V_ZMTyVarBndrZN <*> get 19 -> pure V_ZMTypeZN <*> get 20 -> pure V_ZMZMCharZNZN <*> get n -> error $ (\"deriveSerialize - unexpected tag: \" ++ show n))" :: String)+ $(deriveSerialize [t|ValueType TestPaths|] >>= lift . pprint1))+ , TestCase+ (assertEqual "derivePathInfo Hop"+ ("instance PathInfo key => PathInfo (Hop key) where toPathSegments inp = case inp of NamedField arg arg arg arg arg arg arg -> (++) [pack \"named-field\"] ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) (toPathSegments arg))))))) AnonField arg arg arg arg arg arg -> (++) [pack \"anon-field\"] ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) ((++) (toPathSegments arg) (toPathSegments arg)))))) TupleHop arg -> (++) [pack \"tuple-hop\"] (toPathSegments arg) IndexHop arg -> (++) [pack \"index-hop\"] (toPathSegments arg) ViewHop -> [pack \"view-hop\"] IxViewHop arg -> (++) [pack \"ix-view-hop\"] (toPathSegments arg) fromPathSegments = (<|>) ((<|>) ((<|>) ((<|>) ((<|>) (ap (ap (ap (ap (ap (ap (ap (segment (pack \"named-field\") >> return NamedField) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) (ap (ap (ap (ap (ap (ap (segment (pack \"anon-field\") >> return AnonField) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments) fromPathSegments)) (ap (segment (pack \"tuple-hop\") >> return TupleHop) fromPathSegments)) (ap (segment (pack \"index-hop\") >> return IndexHop) fromPathSegments)) (segment (pack \"view-hop\") >> return ViewHop)) (ap (segment (pack \"ix-view-hop\") >> return IxViewHop) fromPathSegments)" :: String)+ $(derivePathInfo [t|Hop|] >>= lift . pprint1))+ , TestCase+ (assertEqual "derivePathInfo (ProxyType TestPaths)"+ ("instance PathInfo (ProxyType TestPaths) where toPathSegments inp = case inp of P_Eitherz20UURIz20UInteger -> [pack \"p_-eitherz20-u-u-r-iz20-u-integer\"] P_Int -> [pack \"p_-int\"] P_Integer -> [pack \"p_-integer\"] P_Loc -> [pack \"p_-loc\"] P_Maybez20UURIAuth -> [pack \"p_-maybez20-u-u-r-i-auth\"] P_Maybez20UZLEitherz20UURIz20UIntegerZR -> [pack \"p_-maybez20-u-z-l-eitherz20-u-u-r-iz20-u-integer-z-r\"] P_Name -> [pack \"p_-name\"] P_TyLit -> [pack \"p_-ty-lit\"] P_TyVarBndr -> [pack \"p_-ty-var-bndr\"] P_Type -> [pack \"p_-type\"] P_URI -> [pack \"p_-u-r-i\"] P_URIAuth -> [pack \"p_-u-r-i-auth\"] P_ZLIntz2cUz20UIntZR -> [pack \"p_-z-l-intz2c-uz20-u-int-z-r\"] P_ZLIntz2cUz20UTyVarBndrZR -> [pack \"p_-z-l-intz2c-uz20-u-ty-var-bndr-z-r\"] P_ZLIntz2cUz20UTypeZR -> [pack \"p_-z-l-intz2c-uz20-u-type-z-r\"] P_ZLIntz2cUz20UZMCharZNZR -> [pack \"p_-z-l-intz2c-uz20-u-z-m-char-z-n-z-r\"] P_ZMCharZN -> [pack \"p_-z-m-char-z-n\"] P_ZMIntZN -> [pack \"p_-z-m-int-z-n\"] P_ZMTyVarBndrZN -> [pack \"p_-z-m-ty-var-bndr-z-n\"] P_ZMTypeZN -> [pack \"p_-z-m-type-z-n\"] P_ZMZMCharZNZN -> [pack \"p_-z-m-z-m-char-z-n-z-n\"] fromPathSegments = (<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) ((<|>) (segment (pack \"p_-eitherz20-u-u-r-iz20-u-integer\") >> return P_Eitherz20UURIz20UInteger) (segment (pack \"p_-int\") >> return P_Int)) (segment (pack \"p_-integer\") >> return P_Integer)) (segment (pack \"p_-loc\") >> return P_Loc)) (segment (pack \"p_-maybez20-u-u-r-i-auth\") >> return P_Maybez20UURIAuth)) (segment (pack \"p_-maybez20-u-z-l-eitherz20-u-u-r-iz20-u-integer-z-r\") >> return P_Maybez20UZLEitherz20UURIz20UIntegerZR)) (segment (pack \"p_-name\") >> return P_Name)) (segment (pack \"p_-ty-lit\") >> return P_TyLit)) (segment (pack \"p_-ty-var-bndr\") >> return P_TyVarBndr)) (segment (pack \"p_-type\") >> return P_Type)) (segment (pack \"p_-u-r-i\") >> return P_URI)) (segment (pack \"p_-u-r-i-auth\") >> return P_URIAuth)) (segment (pack \"p_-z-l-intz2c-uz20-u-int-z-r\") >> return P_ZLIntz2cUz20UIntZR)) (segment (pack \"p_-z-l-intz2c-uz20-u-ty-var-bndr-z-r\") >> return P_ZLIntz2cUz20UTyVarBndrZR)) (segment (pack \"p_-z-l-intz2c-uz20-u-type-z-r\") >> return P_ZLIntz2cUz20UTypeZR)) (segment (pack \"p_-z-l-intz2c-uz20-u-z-m-char-z-n-z-r\") >> return P_ZLIntz2cUz20UZMCharZNZR)) (segment (pack \"p_-z-m-char-z-n\") >> return P_ZMCharZN)) (segment (pack \"p_-z-m-int-z-n\") >> return P_ZMIntZN)) (segment (pack \"p_-z-m-ty-var-bndr-z-n\") >> return P_ZMTyVarBndrZN)) (segment (pack \"p_-z-m-type-z-n\") >> return P_ZMTypeZN)) (segment (pack \"p_-z-m-z-m-char-z-n-z-n\") >> return P_ZMZMCharZNZN)" :: String)+ $(derivePathInfo [t|ProxyType TestPaths|] >>= lift . pprint1))+#if 0+ , TestCase+ (assertEqual "deriveJSON TraversalPath"+ (concat ["instance (ToJSON (KeyType (t :: *)), ToJSON (ProxyType (t :: *))) => ToJSON (TraversalPath t s a) where ",+ "toJSON = \\value -> case value of TraversalPath arg1 arg2 arg3 -> Array (create (do {mv <- unsafeNew 3; unsafeWrite mv 0 (toJSON arg1); unsafeWrite mv 1 (toJSON arg2); unsafeWrite mv 2 (toJSON arg3); return mv})) ",+ "toEncoding = \\value -> case value of TraversalPath arg1 arg2 arg3 -> Encoding (char7 '[' <> ((builder arg1 <> (char7 ',' <> (builder arg2 <> (char7 ',' <> builder arg3)))) <> char7 ']')) ",+ "instance (FromJSON (KeyType (t :: *)), FromJSON (ProxyType (t :: *))) => FromJSON (TraversalPath t s a) where ",+ "parseJSON = \\value -> case value of ",+ "Array arr -> if length arr == 3 then ((TraversalPath <$> parseJSON (arr `unsafeIndex` 0)) <*> parseJSON (arr `unsafeIndex` 1)) <*> parseJSON (arr `unsafeIndex` 2) else parseTypeMismatch' \"TraversalPath\" \"Types.TraversalPath\" \"Array of length 3\" (\"Array of length \" ++ (show . length) arr) ",+ "other -> parseTypeMismatch' \"TraversalPath\" \"Types.TraversalPath\" \"Array\" (valueConName other)"] :: String)+ $(deriveJSON' defaultOptions [t|TraversalPath|] >>= lift . pprint1))+ , TestCase+ (assertEqual "deriveJSON' defaultOptions [t|ValueType TestPaths|]"+ ("instance ToJSON (ValueType TestPaths) where toJSON = \\value -> case value of V_Eitherz20UURIz20UInteger arg1 -> object [pack \"tag\" .= String (pack \"V_Eitherz20UURIz20UInteger\"), pack \"contents\" .= toJSON arg1] V_Int arg1 -> object [pack \"tag\" .= String (pack \"V_Int\"), pack \"contents\" .= toJSON arg1] V_Integer arg1 -> object [pack \"tag\" .= String (pack \"V_Integer\"), pack \"contents\" .= toJSON arg1] V_Loc arg1 -> object [pack \"tag\" .= String (pack \"V_Loc\"), pack \"contents\" .= toJSON arg1] V_Maybez20UURIAuth arg1 -> object [pack \"tag\" .= String (pack \"V_Maybez20UURIAuth\"), pack \"contents\" .= toJSON arg1] V_Maybez20UZLEitherz20UURIz20UIntegerZR arg1 -> object [pack \"tag\" .= String (pack \"V_Maybez20UZLEitherz20UURIz20UIntegerZR\"), pack \"contents\" .= toJSON arg1] V_Name arg1 -> object [pack \"tag\" .= String (pack \"V_Name\"), pack \"contents\" .= toJSON arg1] V_TyLit arg1 -> object [pack \"tag\" .= String (pack \"V_TyLit\"), pack \"contents\" .= toJSON arg1] V_TyVarBndr arg1 -> object [pack \"tag\" .= String (pack \"V_TyVarBndr\"), pack \"contents\" .= toJSON arg1] V_Type arg1 -> object [pack \"tag\" .= String (pack \"V_Type\"), pack \"contents\" .= toJSON arg1] V_URI arg1 -> object [pack \"tag\" .= String (pack \"V_URI\"), pack \"contents\" .= toJSON arg1] V_URIAuth arg1 -> object [pack \"tag\" .= String (pack \"V_URIAuth\"), pack \"contents\" .= toJSON arg1] V_ZLIntz2cUz20UIntZR arg1 -> object [pack \"tag\" .= String (pack \"V_ZLIntz2cUz20UIntZR\"), pack \"contents\" .= toJSON arg1] V_ZLIntz2cUz20UTyVarBndrZR arg1 -> object [pack \"tag\" .= String (pack \"V_ZLIntz2cUz20UTyVarBndrZR\"), pack \"contents\" .= toJSON arg1] V_ZLIntz2cUz20UTypeZR arg1 -> object [pack \"tag\" .= String (pack \"V_ZLIntz2cUz20UTypeZR\"), pack \"contents\" .= toJSON arg1] V_ZLIntz2cUz20UZMCharZNZR arg1 -> object [pack \"tag\" .= String (pack \"V_ZLIntz2cUz20UZMCharZNZR\"), pack \"contents\" .= toJSON arg1] V_ZMCharZN arg1 -> object [pack \"tag\" .= String (pack \"V_ZMCharZN\"), pack \"contents\" .= toJSON arg1] V_ZMIntZN arg1 -> object [pack \"tag\" .= String (pack \"V_ZMIntZN\"), pack \"contents\" .= toJSON arg1] V_ZMTyVarBndrZN arg1 -> object [pack \"tag\" .= String (pack \"V_ZMTyVarBndrZN\"), pack \"contents\" .= toJSON arg1] V_ZMTypeZN arg1 -> object [pack \"tag\" .= String (pack \"V_ZMTypeZN\"), pack \"contents\" .= toJSON arg1] V_ZMZMCharZNZN arg1 -> object [pack \"tag\" .= String (pack \"V_ZMZMCharZNZN\"), pack \"contents\" .= toJSON arg1] toEncoding = \\value -> case value of V_Eitherz20UURIz20UInteger arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Eitherz20UURIz20UInteger\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Int arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Int\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Integer arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Integer\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Loc arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Loc\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Maybez20UURIAuth arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Maybez20UURIAuth\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Maybez20UZLEitherz20UURIz20UIntegerZR arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Maybez20UZLEitherz20UURIz20UIntegerZR\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Name arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Name\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_TyLit arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_TyLit\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_TyVarBndr arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_TyVarBndr\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_Type arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_Type\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_URI arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_URI\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_URIAuth arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_URIAuth\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZLIntz2cUz20UIntZR arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZLIntz2cUz20UIntZR\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZLIntz2cUz20UTyVarBndrZR arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZLIntz2cUz20UTyVarBndrZR\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZLIntz2cUz20UTypeZR arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZLIntz2cUz20UTypeZR\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZLIntz2cUz20UZMCharZNZR arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZLIntz2cUz20UZMCharZNZR\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZMCharZN arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZMCharZN\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZMIntZN arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZMIntZN\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZMTyVarBndrZN arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZMTyVarBndrZN\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZMTypeZN arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZMTypeZN\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) V_ZMZMCharZNZN arg1 -> Encoding (char7 '{' <> (((text (pack \"tag\") <> (char7 ':' <> text (pack \"V_ZMZMCharZNZN\"))) <> (char7 ',' <> (text (pack \"contents\") <> (char7 ':' <> fromEncoding (toEncoding arg1))))) <> char7 '}')) instance FromJSON (ValueType TestPaths) where parseJSON = \\value -> case value of Object obj -> do {conKey <- obj .: pack \"tag\"; case conKey of _ | conKey == pack \"V_Eitherz20UURIz20UInteger\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Eitherz20UURIz20UInteger <$> parseJSON arg} | conKey == pack \"V_Int\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Int <$> parseJSON arg} | conKey == pack \"V_Integer\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Integer <$> parseJSON arg} | conKey == pack \"V_Loc\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Loc <$> parseJSON arg} | conKey == pack \"V_Maybez20UURIAuth\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Maybez20UURIAuth <$> parseJSON arg} | conKey == pack \"V_Maybez20UZLEitherz20UURIz20UIntegerZR\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Maybez20UZLEitherz20UURIz20UIntegerZR <$> parseJSON arg} | conKey == pack \"V_Name\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Name <$> parseJSON arg} | conKey == pack \"V_TyLit\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_TyLit <$> parseJSON arg} | conKey == pack \"V_TyVarBndr\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_TyVarBndr <$> parseJSON arg} | conKey == pack \"V_Type\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_Type <$> parseJSON arg} | conKey == pack \"V_URI\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_URI <$> parseJSON arg} | conKey == pack \"V_URIAuth\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_URIAuth <$> parseJSON arg} | conKey == pack \"V_ZLIntz2cUz20UIntZR\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZLIntz2cUz20UIntZR <$> parseJSON arg} | conKey == pack \"V_ZLIntz2cUz20UTyVarBndrZR\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZLIntz2cUz20UTyVarBndrZR <$> parseJSON arg} | conKey == pack \"V_ZLIntz2cUz20UTypeZR\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZLIntz2cUz20UTypeZR <$> parseJSON arg} | conKey == pack \"V_ZLIntz2cUz20UZMCharZNZR\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZLIntz2cUz20UZMCharZNZR <$> parseJSON arg} | conKey == pack \"V_ZMCharZN\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZMCharZN <$> parseJSON arg} | conKey == pack \"V_ZMIntZN\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZMIntZN <$> parseJSON arg} | conKey == pack \"V_ZMTyVarBndrZN\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZMTyVarBndrZN <$> parseJSON arg} | conKey == pack \"V_ZMTypeZN\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZMTypeZN <$> parseJSON arg} | conKey == pack \"V_ZMZMCharZNZN\" -> do {val <- obj .: pack \"contents\"; case val of arg -> V_ZMZMCharZNZN <$> parseJSON arg} | otherwise -> conNotFoundFailTaggedObject \"Types.ValueType\" [\"V_Eitherz20UURIz20UInteger\", \"V_Int\", \"V_Integer\", \"V_Loc\", \"V_Maybez20UURIAuth\", \"V_Maybez20UZLEitherz20UURIz20UIntegerZR\", \"V_Name\", \"V_TyLit\", \"V_TyVarBndr\", \"V_Type\", \"V_URI\", \"V_URIAuth\", \"V_ZLIntz2cUz20UIntZR\", \"V_ZLIntz2cUz20UTyVarBndrZR\", \"V_ZLIntz2cUz20UTypeZR\", \"V_ZLIntz2cUz20UZMCharZNZR\", \"V_ZMCharZN\", \"V_ZMIntZN\", \"V_ZMTyVarBndrZN\", \"V_ZMTypeZN\", \"V_ZMZMCharZNZN\"] (unpack conKey)} other -> noObjectFail \"Types.ValueType\" (valueConName other)" :: String)+ $(deriveJSON' defaultOptions [t|ValueType TestPaths|] >>= lift . pprint1))+ , TestCase+ (assertEqual "deriveJSON' defaultOptions [t|OldType Schema1 Author|]"+ ("instance ToJSON (OldType Schema1 Author) where toJSON = \\value -> case value of Author_Schema1 arg1 arg2 arg3 arg4 -> Array (create (do {mv <- unsafeNew 4; unsafeWrite mv 0 (toJSON arg1); unsafeWrite mv 1 (toJSON arg2); unsafeWrite mv 2 (toJSON arg3); unsafeWrite mv 3 (toJSON arg4); return mv})) toEncoding = \\value -> case value of Author_Schema1 arg1 arg2 arg3 arg4 -> Encoding (char7 '[' <> ((builder arg1 <> (char7 ',' <> (builder arg2 <> (char7 ',' <> (builder arg3 <> (char7 ',' <> builder arg4)))))) <> char7 ']')) instance FromJSON (OldType Schema1 Author) where parseJSON = \\value -> case value of Array arr -> if length arr == 4 then (((Author_Schema1 <$> parseJSON (arr `unsafeIndex` 0)) <*> parseJSON (arr `unsafeIndex` 1)) <*> parseJSON (arr `unsafeIndex` 2)) <*> parseJSON (arr `unsafeIndex` 3) else parseTypeMismatch' \"Author_Schema1\" \"Types.OldType\" \"Array of length 4\" (\"Array of length \" ++ (show . length) arr) other -> parseTypeMismatch' \"Author_Schema1\" \"Types.OldType\" \"Array\" (valueConName other)" :: String)+ $(deriveJSON' defaultOptions [t|OldType Schema1 Author|] >>= lift . pprint1))+#endif+ , TestCase+ (assertEqual "derivePathInfo TraversalPath"+ ("instance (PathInfo (KeyType t), PathInfo (ProxyType t)) => PathInfo (TraversalPath t s a) where toPathSegments inp = case inp of TraversalPath arg arg arg -> (++) [pack \"traversal-path\"] ((++) (toPathSegments arg) ((++) (toPathSegments arg) (toPathSegments arg))) fromPathSegments = ap (ap (ap (segment (pack \"traversal-path\") >> return TraversalPath) fromPathSegments) fromPathSegments) fromPathSegments" :: String)+ $(derivePathInfo [t|TraversalPath|] >>= lift . pprint1))+ , TestCase (assertEqual "monomorphize Hop" ("Hop key" :: String) $(monomorphize [t|Hop|] >>= lift . pprint1))+ , TestCase (assertEqual "monomorphize TraversalPath" ("TraversalPath t s a" :: String) $(monomorphize [t|TraversalPath|] >>= lift . pprint1))+ , TestCase (assertEqual "monomorphize TraversalPath" ("TraversalPath TestPaths s a" :: String) $(monomorphize [t|TraversalPath TestPaths|] >>= lift . pprint1))+ ]++-- | Without a specialized concat the text values come out as @pack ['a', 'b', 'c']@+concat :: [String] -> String+concat = mconcat++main :: IO ()+main = do+ counts <- runTestTT tests+ case counts of+ Counts {errors = 0, failures = 0} -> pure ()+ _ -> error (showCounts counts)
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name: th-typegraph-version: 1.0.2+version: 1.4 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -18,29 +18,43 @@ of deriveSafeCopy and derivePathInfo that use the traversal to avoid adding phantom types to the context of the instance. tested-with: GHC == 7.10.3, GHC == 7.11.*+data-files: include/overlapping-compat.h library default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -O2 exposed-modules:+ Language.Haskell.TH.TypeGraph.Constraints Language.Haskell.TH.TypeGraph.Orphans Language.Haskell.TH.TypeGraph.Phantom- Language.Haskell.TH.TypeGraph.SafeCopyDerive+ Language.Haskell.TH.TypeGraph.Prelude+ Language.Haskell.TH.TypeGraph.Serialize Language.Haskell.TH.TypeGraph.TypeTraversal Language.Haskell.TH.TypeGraph.WebRoutesTH+ Data.SafeCopy.Derive build-depends:- aeson,+ attoparsec, base >= 4.8 && < 5,+ bytestring, cereal, containers,+ deepseq,+ dlist,+ fail, fgl,+ ghc-prim,+ hashable, lens, mtl, parsec, pretty >= 1.1.2, safecopy,+ scientific,+ semigroups, split,+ sr-extra, syb,+ tagged, template-haskell >= 2.10, text, th-desugar,@@ -48,8 +62,20 @@ th-lift-instances >= 0.1.7, th-orphans, time,+ transformers,+ unordered-containers, userid,+ vector, web-routes+ include-dirs: include++test-suite th-typegraph-tests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base, th-lift, HUnit, aeson, syb, template-haskell, network-uri, th-typegraph source-repository head type: git