diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -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 diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeCopy/Derive.hs @@ -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 _ = "_" diff --git a/src/Language/Haskell/TH/TypeGraph/Constraints.hs b/src/Language/Haskell/TH/TypeGraph/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/TypeGraph/Constraints.hs @@ -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) diff --git a/src/Language/Haskell/TH/TypeGraph/Orphans.hs b/src/Language/Haskell/TH/TypeGraph/Orphans.hs --- a/src/Language/Haskell/TH/TypeGraph/Orphans.hs +++ b/src/Language/Haskell/TH/TypeGraph/Orphans.hs @@ -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) diff --git a/src/Language/Haskell/TH/TypeGraph/Phantom.hs b/src/Language/Haskell/TH/TypeGraph/Phantom.hs --- a/src/Language/Haskell/TH/TypeGraph/Phantom.hs +++ b/src/Language/Haskell/TH/TypeGraph/Phantom.hs @@ -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 = diff --git a/src/Language/Haskell/TH/TypeGraph/Prelude.hs b/src/Language/Haskell/TH/TypeGraph/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/TypeGraph/Prelude.hs @@ -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) diff --git a/src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs b/src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs deleted file mode 100644 --- a/src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs +++ /dev/null @@ -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 _ = "_" diff --git a/src/Language/Haskell/TH/TypeGraph/Serialize.hs b/src/Language/Haskell/TH/TypeGraph/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/TypeGraph/Serialize.hs @@ -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) diff --git a/src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs b/src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs --- a/src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs +++ b/src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs @@ -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" diff --git a/src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs b/src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs --- a/src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs +++ b/src/Language/Haskell/TH/TypeGraph/WebRoutesTH.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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) diff --git a/th-typegraph.cabal b/th-typegraph.cabal --- a/th-typegraph.cabal +++ b/th-typegraph.cabal @@ -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