diff --git a/Language/Haskell/TH/Context.hs b/Language/Haskell/TH/Context.hs --- a/Language/Haskell/TH/Context.hs +++ b/Language/Haskell/TH/Context.hs @@ -6,41 +6,57 @@ -- I say "nearly correct" because there are cases which are -- not handled exactly the way GHC behaves, which may lead to -- false (positives? negatives?) -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Language.Haskell.TH.Context ( InstMap + , DecStatus(Declared, Undeclared, instanceDec) , reifyInstancesWithContext , tellInstance - -- * State/writer monad runners - , evalContextState - , execContextWriter - , execContext - , runContext + , tellUndeclared ) where -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>), (<*>)) -import Data.Monoid (mempty) -#else import Data.Maybe (isJust) -#endif import Control.Monad (filterM) -import Control.Monad.State (MonadState, StateT, get, modify, evalStateT) -import Control.Monad.Writer (MonadWriter, tell, WriterT, execWriterT, runWriterT) +import Control.Monad.State (get, modify, StateT) +import Control.Monad.Writer (MonadWriter, tell) import Data.Generics (everywhere, mkT) -import Data.List ({-dropWhileEnd,-} intercalate) -import Data.Map as Map (Map, lookup, insert, singleton, elems) +import Data.List (intercalate) +import Data.Map as Map (elems, insert, lookup, Map) +import Data.Maybe (mapMaybe) +-- import Debug.Trace (trace) import Language.Haskell.TH -import Language.Haskell.TH.Context.Expand (expandPred, expandClassP) -import Language.Haskell.TH.Context.Helpers (pprint') import Language.Haskell.TH.Desugar as DS (DsMonad) +import Language.Haskell.TH.PprLib (cat, ptext) import Language.Haskell.TH.Syntax hiding (lift) +import Language.Haskell.TH.TypeGraph.Expand (ExpandMap, expandType, E(unE)) +import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState)) import Language.Haskell.TH.Instances ({- Ord instances from th-orphans -}) -type InstMap pred = Map pred [InstanceDec] +-- FIXME: Should actually be Map (E Pred) (Maybe (DecStatus +-- InstanceDec)), because having more than one instance would be a +-- compile error. +type InstMap = Map (E Pred) [DecStatus InstanceDec] +-- | Did we get this instance from the Q monad or does it still need to be spliced? +data DecStatus a + = Declared {instanceDec :: a} + -- ^ An instance we found in the Q monad + | Undeclared {instanceDec :: a} + -- ^ An instance we inserted via tellInstance + deriving Show + +instance Ppr a => Ppr (DecStatus a) where + ppr (Undeclared x) = cat [ptext "Undeclared (", ppr x, ptext ")"] + ppr (Declared x) = cat [ptext "Declared (", ppr x, ptext ")"] + -- | Like 'qReifyInstances', looks up all the instances that match the -- given class name and argument types. Unlike 'qReifyInstances', -- only the ones that satisfy all the instance context predicates in @@ -50,42 +66,41 @@ -- monad 'InstMap', associated with an empty list of predicates, and the -- empty list is returned. Later the caller can use 'tellInstance' to -- associate instances with the predicate. -reifyInstancesWithContext :: (DsMonad m, MonadState (InstMap Pred) m) => +reifyInstancesWithContext :: forall m. (DsMonad m, HasState InstMap m, HasState ExpandMap m) => Name -> [Type] -> m [InstanceDec] reifyInstancesWithContext className typeParameters = do - p <- expandClassP className typeParameters - mp <- get - case Map.lookup p mp of - Just x -> return x - Nothing -> do - -- Add an entry with a bogus value to limit recursion on - -- the predicate we are currently testing - modify (Map.insert p []) - -- Get all the instances of className that unify with the type parameters. - insts <- qReifyInstances className typeParameters - -- Filter out the ones that conflict with the instance context - r <- filterM (testInstance className typeParameters) insts - -- Now insert the correct value into the map and return it. - modify (Map.insert p r) - return r + p <- expandType $ foldInstance className typeParameters + mp <- getState :: m InstMap + case Map.lookup p mp of + Just x -> return $ map instanceDec x + Nothing -> do + -- trace (" -> reifyInstancesWithContext " ++ pprint (foldInstance className typeParameters) ++ "...") (return ()) + -- Add an entry with a bogus value to limit recursion on + -- the predicate we are currently testing + modifyState (Map.insert p [] :: InstMap -> InstMap) + -- Get all the instances of className that unify with the type parameters. + insts <- qReifyInstances className typeParameters + -- Filter out the ones that conflict with the instance context + r <- filterM (testInstance className typeParameters) insts + -- Now insert the correct value into the map and return it. Because + -- this instance was discovered in the Q monad it is marked Declared. + modifyState (Map.insert p (map Declared r)) + -- trace (" <- reifyInstancesWithContext " ++ pprint (foldInstance className typeParameters) ++ " -> " ++ pprint r) (return ()) + return r -- | Test one of the instances returned by qReifyInstances against the -- context we have computed so far. We have already added a ClassP predicate -- for the class and argument types, we now need to unify those with the -- type returned by the instance and generate some EqualP predicates. -testInstance :: (DsMonad m, MonadState (InstMap Pred) m) => Name -> [Type] -> InstanceDec -> m Bool +testInstance :: (DsMonad m, HasState InstMap m, HasState ExpandMap m) => Name -> [Type] -> InstanceDec -> m Bool testInstance className typeParameters (InstanceD instanceContext instanceType _) = do -- The new context consists of predicates derived by unifying the -- type parameters with the instance type, plus the prediates in the -- instance context field. - mapM expandPred (instancePredicates (reverse typeParameters) instanceType ++ instanceContext) >>= testContext + mapM expandType (instancePredicates (reverse typeParameters) instanceType ++ instanceContext) >>= testContext . map unE where instancePredicates :: [Type] -> Type -> [Pred] -#if MIN_VERSION_template_haskell(2,10,0) instancePredicates (x : xs) (AppT l r) = AppT (AppT EqualityT x) r : instancePredicates xs l -#else - instancePredicates (x : xs) (AppT l r) = EqualP x r : instancePredicates xs l -#endif instancePredicates [] (ConT className') | className == className' = [] instancePredicates _ _ = error $ (unlines ["testInstance: Failure unifying instance with arguments. This should never", @@ -98,13 +113,13 @@ -- parameters with the instance type. Are they consistent? Find out -- using type synonym expansion, variable substitution, elimination of -- vacuous predicates, and unification. -testContext :: (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m Bool +testContext :: (DsMonad m, HasState InstMap m, HasState ExpandMap m) => [Pred] -> m Bool testContext context = - and <$> (mapM consistent =<< simplifyContext context) + and <$> (simplifyContext context >>= mapM consistent) -- | Perform type expansion on the predicates, then simplify using -- variable substitution and eliminate vacuous equivalences. -simplifyContext :: (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m [Pred] +simplifyContext :: (DsMonad m, HasState InstMap m) => [Pred] -> m [Pred] simplifyContext context = do let context' = concat $ map unify context let context'' = foldl simplifyPredicate context' context' @@ -113,57 +128,24 @@ -- | Try to simplify the context by eliminating of one of the predicates. -- If we succeed start again with the new context. simplifyPredicate :: [Pred] -> Pred -> [Pred] -#if MIN_VERSION_template_haskell(2,10,0) simplifyPredicate context (AppT (AppT EqualityT v@(VarT _)) b) = everywhere (mkT (\ x -> if x == v then b else x)) context simplifyPredicate context (AppT (AppT EqualityT a) v@(VarT _)) = everywhere (mkT (\ x -> if x == v then a else x)) context simplifyPredicate context p@(AppT (AppT EqualityT a) b) | a == b = filter (/= p) context -#else -simplifyPredicate context (EqualP v@(VarT _) b) = everywhere (mkT (\ x -> if x == v then b else x)) context -simplifyPredicate context (EqualP a v@(VarT _)) = everywhere (mkT (\ x -> if x == v then a else x)) context -simplifyPredicate context p@(EqualP a b) | a == b = filter (/= p) context -#endif simplifyPredicate context _ = context --- | Test the context (predicates) against both the instances in the Q --- monad and the additional instances that have accumulated in the --- State monad. -#if 0 -testContextWithState :: forall m pred. (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m Bool -testContextWithState context = do - -- Is the instance already in the Q monad? - flag <- testContext context - case flag of - True -> return True - -- Have we already generated and inserted the instance into the - -- map in the state monad? (Shouldn't we try this before calling - -- testContext?) - False -> and <$> mapM testPredicate context - where - testPredicate :: Pred -> m Bool - testPredicate predicate = maybe False (not . null) <$> (Map.lookup predicate <$> get) -#endif - -- | Unify the two arguments of an EqualP predicate, return a list of -- simpler predicates associating types with a variables. unify :: Pred -> [Pred] -#if MIN_VERSION_template_haskell(2,10,0) unify (AppT (AppT EqualityT (AppT a b)) (AppT c d)) = unify (AppT (AppT EqualityT a) c) ++ unify (AppT (AppT EqualityT b) d) unify (AppT (AppT EqualityT (ConT a)) (ConT b)) | a == b = [] unify (AppT (AppT EqualityT a@(VarT _)) b) = [AppT (AppT EqualityT a) b] unify (AppT (AppT EqualityT a) b@(VarT _)) = [AppT (AppT EqualityT a) b] -#else -unify (EqualP (AppT a b) (AppT c d)) = unify (EqualP a c) ++ unify (EqualP b d) -unify (EqualP (ConT a) (ConT b)) | a == b = [] -unify (EqualP a@(VarT _) b) = [EqualP a b] -unify (EqualP a b@(VarT _)) = [EqualP a b] -#endif unify x = [x] -- | Decide whether a predicate is consistent with the accumulated --- context. Use recursive calls to qReifyInstancesWithContext when +-- context. Use recursive calls to reifyInstancesWithContext when -- we encounter a class name applied to a list of type parameters. -consistent :: (DsMonad m, MonadState (InstMap Pred) m) => Pred -> m Bool -#if MIN_VERSION_template_haskell(2,10,0) +consistent :: (DsMonad m, HasState InstMap m, HasState ExpandMap m) => Pred -> m Bool consistent typ | isJust (unfoldInstance typ) = let Just (className, typeParameters) = unfoldInstance typ in @@ -176,55 +158,51 @@ consistent (AppT (AppT EqualityT a) b) | a == b = return True consistent (AppT (AppT EqualityT _) _) = return False consistent typ = error $ "Unexpected Pred: " ++ pprint typ -#else -consistent (EqualP (AppT a b) (AppT c d)) = - -- I'm told this is incorrect in the presence of type functions - (&&) <$> consistent (EqualP a c) <*> consistent (EqualP b d) -consistent (EqualP (VarT _) _) = return True -consistent (EqualP _ (VarT _)) = return True -consistent (EqualP a b) | a == b = return True -consistent (EqualP _ _) = return False -consistent (ClassP className typeParameters) = - (not . null) <$> reifyInstancesWithContext className typeParameters -- Do we need additional context here? -#endif --- | Declare an instance to the state and writer monads. After this, --- the instance predicate (constructed from class namd and type +-- | Declare an instance in the state monad, marked Undeclared. After +-- this, the instance predicate (constructed from class name and type -- parameters) will be considered part of the context for subsequent --- calls to qReifyInstancesWithContext. The instance will be returned --- when the writer monad exists so it can be spliced into to program. -tellInstance :: (DsMonad m, MonadWriter (InstMap Pred) m, MonadState (InstMap Pred) m, Quasi m) => - Dec -> m () +-- calls to reifyInstancesWithContext. +tellInstance :: (DsMonad m, HasState InstMap m, Quasi m, HasState ExpandMap m) => Dec -> m () tellInstance inst@(InstanceD _ instanceType _) = do let Just (className, typeParameters) = unfoldInstance instanceType -#if MIN_VERSION_template_haskell(2,10,0) - p <- expandPred $ foldl AppT (ConT className) typeParameters -#else - p <- expandPred $ ClassP className typeParameters -#endif - st <- get - case Map.lookup p st of + p <- expandType $ foldInstance className typeParameters + (mp :: InstMap) <- getState + case Map.lookup p mp of Just (_ : _) -> return () - _ -> do -- trace (" " ++ pprint' instanceType) (return ()) - tell $ Map.singleton p [inst] - modify $ Map.insert p [inst] -tellInstance inst = error $ "tellInstance - Not an instance: " ++ pprint' inst - -unfoldInstance :: Type -> Maybe (Name, [Type]) -unfoldInstance (ConT name) = Just (name, []) -unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1) -unfoldInstance _ = Nothing + -- Here we set the instance list to a singleton - there is + -- no point associating multiple instances with a predicate, + -- compiling the resulting set of declarations is an error + -- (overlapping instances.) + _ -> modifyState (Map.insert p [Undeclared inst]) +tellInstance inst = error $ "tellInstance - Not an instance: " ++ pprint inst -evalContextState :: Monad m => StateT (InstMap Pred) m r -> m r -evalContextState action = evalStateT action (mempty :: (InstMap Pred)) +-- A basic HasState InstMap instance. +instance Monad m => HasState InstMap (StateT InstMap m) where + getState = get + modifyState = modify -execContextWriter :: Monad m => WriterT (InstMap Pred) m () -> m (InstMap Pred) -execContextWriter = execWriterT +-- | After all the declared and undeclared instances have been added +-- to the instance map using tellInstance, this returns the undeclared +-- instances only, not the ones that were discovered by +-- reifyInstances, and tells them to the writer monad. +tellUndeclared :: (MonadWriter [Dec] m, HasState InstMap m) => m () +tellUndeclared = + getState >>= \(mp :: InstMap) -> tell . mapMaybe undeclared . concat . Map.elems $ mp + where + undeclared :: DecStatus Dec -> Maybe Dec + undeclared (Undeclared dec) = Just dec + undeclared (Declared _) = Nothing --- | Typical use: run both state and writer monads to generate a list of --- instance declarations. -execContext :: (Monad m, Functor m) => StateT (InstMap Pred) (WriterT (InstMap Pred) m) () -> m [Dec] -execContext action = (concat . Map.elems) <$> (execWriterT $ evalContextState action) +-- | Turn a type Name and a list of Type parameters into a Pred (which +-- is now just a Type.) +foldInstance :: Name -> [Type] -> Pred +foldInstance className typeParameters = foldl AppT (ConT className) typeParameters -runContext :: (Monad m, Functor m) => StateT (InstMap Pred) (WriterT (InstMap Pred) m) r -> m (r, (InstMap Pred)) -runContext action = runWriterT $ evalContextState action +-- | The inverse of foldInstance. Returns Nothing if the Pred is +-- incorrectly formatted - i.e. not in a form that 'foldInstance' can +-- produce. +unfoldInstance :: Pred -> Maybe (Name, [Type]) +unfoldInstance (ConT name) = Just (name, []) +unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1) +unfoldInstance _ = Nothing diff --git a/Language/Haskell/TH/Context/Expand.hs b/Language/Haskell/TH/Context/Expand.hs deleted file mode 100644 --- a/Language/Haskell/TH/Context/Expand.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | The 'Expanded' class helps keep track of which 'Type' values have --- been fully expanded to a canonical form. This lets us use the 'Eq' --- and 'Ord' relationships on 'Type' and 'Pred' values when reasoning --- about instance context. -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.TH.Context.Expand - ( Expanded(markExpanded, runExpanded) - , expandType - , expandPred - , expandClassP - , E - ) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif -import Language.Haskell.Exts.Syntax () -import Language.Haskell.TH -import Language.Haskell.TH.Desugar as DS (DsMonad, dsType, expand, typeToTH) -import Language.Haskell.TH.Instances () -import Prelude hiding (pred) - --- | This class lets us use the same expand* functions to work with --- specially marked expanded types or with the original types. -class Expanded un ex | ex -> un where - markExpanded :: un -> ex -- | Unsafely mark a value as expanded - runExpanded :: ex -> un -- | Strip mark off an expanded value - --- | Apply the th-desugar expand function to a 'Type' and mark it as expanded. -expandType :: (DsMonad m, Expanded Type e) => Type -> m e -expandType typ = markExpanded <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand) - --- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded. --- Note that the definition of 'Pred' changed in template-haskell-2.10.0.0. -expandPred :: (DsMonad m, Expanded Pred e) => Pred -> m e -#if MIN_VERSION_template_haskell(2,10,0) -expandPred pred = markExpanded <$> expandType pred -#else -expandPred (ClassP className typeParameters) = markExpanded <$> ClassP className <$> mapM expandType typeParameters -expandPred (EqualP type1 type2) = markExpanded <$> (EqualP <$> expandType type1 <*> expandType type2) -#endif - --- | Expand a list of 'Type' and build an expanded 'ClassP' 'Pred'. -expandClassP :: forall m e. (DsMonad m, Expanded Pred e) => Name -> [Type] -> m e -expandClassP className typeParameters = - markExpanded <$> -#if MIN_VERSION_template_haskell(2,10,0) - (expandType $ foldl AppT (ConT className) typeParameters) :: m e -#else - ClassP className <$> mapM expandType typeParameters -#endif - --- | A concrete type for which Expanded instances are declared below. -newtype E a = E a deriving (Eq, Ord, Show) - -instance Expanded Type Type where - markExpanded = id - runExpanded = id - -instance Expanded Type (E Type) where - markExpanded = E - runExpanded (E x) = x - -#if !MIN_VERSION_template_haskell(2,10,0) -instance Expanded Pred Pred where - markExpanded = id - runExpanded = id - -instance Expanded Pred (E Pred) where - markExpanded = E - runExpanded (E x) = x -#endif - -instance Ppr a => Ppr (E a) where - ppr (E x) = ppr x diff --git a/Language/Haskell/TH/Context/Helpers.hs b/Language/Haskell/TH/Context/Helpers.hs deleted file mode 100644 --- a/Language/Haskell/TH/Context/Helpers.hs +++ /dev/null @@ -1,134 +0,0 @@ --- | Helper functions for dealing with record fields, type shape, type --- arity, primitive types, and pretty printing. -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.TH.Context.Helpers - ( -- * Declaration shape - FieldType(FieldType, fPos, fNameAndType) - , fName - , fType - , prettyField - , constructorFields - , foldShape - -- * Constructor deconstructors - , constructorName - -- * Queries - , typeArity - , unlifted - -- * Pretty print without extra whitespace - , pprint' - ) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>), (<*>)) -#endif -import Data.Data (Data) -import Data.Typeable (Typeable) -import Language.Haskell.Exts.Syntax () -import Language.Haskell.TH -import Language.Haskell.TH.Desugar ({- instances -}) -import Language.Haskell.TH.Syntax hiding (lift) - -data FieldType - = FieldType - { fPos :: Int - , fNameAndType :: Either StrictType VarStrictType } - deriving (Eq, Ord, Show, Data, Typeable) - -fName :: FieldType -> Maybe Name -fName = either (\ (_, _) -> Nothing) (\ (x, _, _) -> Just x) . fNameAndType - -prettyField :: FieldType -> String -prettyField fld = maybe (show (fPos fld)) nameBase (fName fld) - --- | fType' with leading foralls stripped -fType :: FieldType -> Type -fType = either (\ (_, x) -> x) (\ (_, _, x) -> x) . fNameAndType - --- | Given the list of constructors from a Dec, dispatch on the --- different levels of complexity of the type they represent - a --- wrapper is a single arity one constructor, an enum is --- several arity zero constructors, and so on. -foldShape :: Monad m => - ([(Con, [FieldType])] -> m r) -- dataFn - several constructors not all of which are arity zero - -> (Con -> [FieldType] -> m r) -- recordFn - one constructor which has arity greater than one - -> ([Con] -> m r) -- enumFn - all constructors are of arity zero - -> (Con -> FieldType -> m r) -- wrapperFn - one constructor of arity one - -> [Con] -> m r -foldShape dataFn recordFn enumFn wrapperFn cons = - case zip cons (map constructorFields cons) :: [(Con, [FieldType])] of - [(con, [fld])] -> - wrapperFn con fld - [(con, flds)] -> - recordFn con flds - pairs | all (== 0) (map (length . snd) pairs) -> - enumFn (map fst pairs) - pairs -> - dataFn pairs - -constructorName :: Con -> Name -constructorName (ForallC _ _ con) = constructorName con -constructorName (NormalC name _) = name -constructorName (RecC name _) = name -constructorName (InfixC _ name _) = name - -constructorFields :: Con -> [FieldType] -constructorFields (ForallC _ _ con) = constructorFields con -constructorFields (NormalC _ ts) = map (uncurry FieldType) (zip [1..] (map Left ts)) -constructorFields (RecC _ ts) = map (uncurry FieldType) (zip [1..] (map Right ts)) -constructorFields (InfixC t1 _ t2) = map (uncurry FieldType) [(1, Left t1), (2, Left t2)] - --- | Compute the arity of a type - the number of type parameters that --- must be applied to it in order to obtain a concrete type. -typeArity :: Quasi m => Type -> m Int -typeArity (ForallT _ _ typ) = typeArity typ -typeArity ListT = return 1 -typeArity (VarT _) = return 1 -typeArity (TupleT n) = return n -typeArity (AppT t _) = typeArity t >>= \ n -> return $ n - 1 -typeArity (ConT name) = qReify name >>= infoArity - where - infoArity (TyConI dec) = decArity dec - infoArity (PrimTyConI _ _ _) = return 0 - infoArity (FamilyI dec _) = decArity dec - infoArity info = error $ "typeArity - unexpected: " ++ pprint' info - decArity (DataD _ _ vs _ _) = return $ length vs - decArity (NewtypeD _ _ vs _ _) = return $ length vs - decArity (TySynD _ vs t) = typeArity t >>= \ n -> return $ n + length vs - decArity (FamilyD _ _ vs _mk) = return $ {- not sure what to do with the kind mk here -} length vs - decArity dec = error $ "decArity - unexpected: " ++ show dec -typeArity typ = error $ "typeArity - unexpected type: " ++ show typ - --- | Pretty print a 'Ppr' value on a single line with each block of --- white space (newlines, tabs, etc.) converted to a single space. -pprint' :: Ppr a => a -> [Char] -pprint' typ = unwords $ words $ pprint typ - --- | Does the type or the declaration to which it refers contain a --- primitive (aka unlifted) type? This will traverse down any 'Dec' --- to the named types, and then check whether any of their 'Info' --- records are 'PrimTyConI' values. -class IsUnlifted t where - unlifted :: Quasi m => t -> m Bool - -instance IsUnlifted Dec where - unlifted (DataD _ _ _ cons _) = or <$> mapM unlifted cons - unlifted (NewtypeD _ _ _ con _) = unlifted con - unlifted (TySynD _ _ typ) = unlifted typ - unlifted _ = return False - -instance IsUnlifted Con where - unlifted (ForallC _ _ con) = unlifted con - unlifted (NormalC _ ts) = or <$> mapM (unlifted . snd) ts - unlifted (RecC _ ts) = or <$> mapM (\ (_, _, t) -> unlifted t) ts - unlifted (InfixC t1 _ t2) = or <$> mapM (unlifted . snd) [t1, t2] - -instance IsUnlifted Type where - unlifted (ForallT _ _ typ) = unlifted typ - unlifted (ConT name) = qReify name >>= unlifted - unlifted (AppT t1 t2) = (||) <$> unlifted t1 <*> unlifted t2 - unlifted _ = return False - -instance IsUnlifted Info where - unlifted (PrimTyConI _ _ _) = return True - unlifted _ = return False -- traversal stops here diff --git a/Language/Haskell/TH/Context/Simple.hs b/Language/Haskell/TH/Context/Simple.hs deleted file mode 100644 --- a/Language/Haskell/TH/Context/Simple.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Naive instance filtering (as in @th-reify-many@.) Mostly for comparison --- to @qReifyInstancesWithContext@. -module Language.Haskell.TH.Context.Simple - ( missingInstances - , simpleMissingInstanceTest - ) where - -import Data.Maybe (catMaybes) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Instances ({- Ord instances from th-orphans -}) - --- | Apply a filter such as 'simpleMissingInstanceTest' to a list of --- instances, resulting in a non-overlapping list of instances. -missingInstances :: Quasi m => (Dec -> m Bool) -> m [Dec] -> m [Dec] -missingInstances test decs = decs >>= mapM (\ dec -> test dec >>= \ flag -> return $ if flag then Just dec else Nothing) >>= return . catMaybes - --- | Return True if no instance matches the types (ignoring the instance context.) --- Passing qReifyInstance as the reifyInstanceFunction argument gives a naive test, --- passing qReifyInstanceWithContext will also accept (return True for) instances --- which... -simpleMissingInstanceTest :: Quasi m => Dec -> m Bool -simpleMissingInstanceTest dec@(InstanceD _ typ _) = - case unfoldInstance typ of - Just (name, types) -> do - -- trace ("name: " ++ show name ++ ", types=" ++ show types) (return ()) - insts <- qReifyInstances name types - -- trace ("insts: " ++ show (map pprint insts)) (return ()) - return $ null insts - Nothing -> error $ "simpleMissingInstanceTest - invalid instance: " ++ pprint dec -simpleMissingInstanceTest dec = error $ "simpleMissingInstanceTest - invalid instance: " ++ pprint dec - -unfoldInstance :: Type -> Maybe (Name, [Type]) -unfoldInstance (ConT name) = Just (name, []) -unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1) -unfoldInstance _ = Nothing diff --git a/Language/Haskell/TH/TypeGraph.hs b/Language/Haskell/TH/TypeGraph.hs deleted file mode 100644 --- a/Language/Haskell/TH/TypeGraph.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} -module Language.Haskell.TH.TypeGraph - ( VertexStatus(..) - , TypeGraphEdges - , typeGraphEdges - , typeGraphVertices - , typeGraph - ) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -import Data.Monoid (mempty) -#endif -import Control.Monad.State (execStateT, modify, MonadState(get), StateT) -import Control.Monad.Trans (lift) -import Data.Default (Default(def)) -import Data.Graph (Graph, Vertex, graphFromEdges) -import Data.Map as Map (Map, keys, lookup, toList, update, alter) -import Data.Set as Set (insert, Set, empty, fromList, toList) -import Language.Haskell.Exts.Syntax () -import Language.Haskell.TH -- (Con, Dec, nameBase, Type) -import Language.Haskell.TH.Desugar as DS (DsMonad) -import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Syntax (Quasi(..)) - -type TypeGraphEdges typ = Map typ (Set typ) - --- | When a VertexStatus value is associated with a Type it describes --- alterations in the type graph from the usual default. -data VertexStatus typ - = Vertex -- ^ normal case - | NoVertex -- ^ exclude this type from the graph - | Sink -- ^ out degree zero - don't create any outgoing edges - | Divert typ -- ^ replace all outgoing edges with an edge to an alternate type - | Extra typ -- ^ add an extra outgoing edge to the given type - deriving Show - -instance Default (VertexStatus typ) where - def = Vertex - --- | Return the set of types embedded in the given type. This is just --- the nodes of the type graph. The type aliases are expanded by the --- th-desugar package to make them suitable for use as map keys. -typeGraphVertices :: DsMonad m => - (Type -> m (VertexStatus Type)) - -> [Type] - -> m (Set Type) -typeGraphVertices augment types = - (Set.fromList . Map.keys) <$> typeGraphEdges augment types - -typeGraphEdges - :: forall m. DsMonad m => - (Type -> m (VertexStatus Type)) - -- ^ This function is applied to every expanded type before - -- use, and the result is used instead. If it returns - -- NoVertex, no vertices or edges are added to the graph. - -- If it returns Sink no outgoing edges are added. The - -- current use case Substitute is to see if there is an - -- instance of class @View a b@ where @a@ is the type - -- passed to @doType@, and replace it with @b@, and use the - -- lens returned by @View's@ method to convert between @a@ - -- and @b@ (i.e. to implement the edge in the type graph.) - -> [Type] - -> m (TypeGraphEdges Type) - -typeGraphEdges augment types = do - execStateT (mapM_ doNode types) mempty - where - doNode :: Type -> StateT (TypeGraphEdges Type) m () - doNode typ = do - mp <- get - status <- lift (augment typ) - case Map.lookup typ mp of - Just _ -> return () - Nothing -> - case status of - NoVertex -> return () - Sink -> addNode typ - (Divert typ') -> addNode typ >> addEdge typ typ' >> doNode typ' - (Extra typ') -> addNode typ >> doEdges typ >> addEdge typ typ' >> doNode typ' - Vertex -> addNode typ >> doEdges typ - - addNode :: Type -> StateT (TypeGraphEdges Type) m () - -- addNode a = expandType a >>= \ a' -> modify $ Map.insertWith (flip const) a' Set.empty - addNode a = modify $ Map.alter (maybe (Just Set.empty) Just) a - addEdge :: Type -> Type -> StateT (TypeGraphEdges Type) m () - addEdge a b = modify $ Map.update (Just . Set.insert b) a - - -- We know that the Type argument is actually fully expanded here. - doEdges :: Type -> StateT (TypeGraphEdges Type) m () - doEdges typ@(ForallT _ _ typ') = addEdge typ typ' >> doNode typ' - doEdges typ@(AppT container element) = - addEdge typ container >> - addEdge typ element >> - doNode container >> - doNode element - -- Can this happen if typ is fully expanded? - doEdges typ@(ConT name) = do - info <- qReify name - case info of - TyConI dec -> doDec dec - _ -> return () - where - doDec :: Dec -> StateT (TypeGraphEdges Type) m () - doDec dec@(NewtypeD _ tname _ con _) = doCon tname dec con - doDec dec@(DataD _ tname _ cons _) = mapM_ (doCon tname dec) cons - doDec (TySynD _tname _tvars typ') = addEdge typ typ' >> doNode typ' - doDec _ = return () - - doCon :: Name -> Dec -> Con -> StateT (TypeGraphEdges Type) m () - doCon tname dec (ForallC _ _ con) = doCon tname dec con - doCon tname dec (NormalC cname fields) = mapM_ (doField tname dec cname) (zip (map Left ([1..] :: [Int])) (map snd fields)) - doCon tname dec (RecC cname fields) = mapM_ (doField tname dec cname) (map (\ (fname, _, typ') -> (Right fname, typ')) fields) - doCon tname dec (InfixC (_, lhs) cname (_, rhs)) = mapM_ (doField tname dec cname) [(Left 1, lhs), (Left 2, rhs)] - - doField _tname _dec _cname (_fld, ftype) = addEdge typ ftype >> doNode ftype - - doEdges _typ = return ({-trace ("Unrecognized type: " ++ pprint' typ)-} ()) - --- | Build a graph from the result of typeGraphEdges, each edge goes --- from a type to one of the types it contains. Thus, each edge --- represents a primitive lens, and each path in the graph is a --- composition of lenses. -typeGraph :: (DsMonad m, node ~ Type, key ~ Type) => - (Type -> m (VertexStatus Type)) -> [Type] -> m (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) -typeGraph augment types = do - typeGraphEdges augment types >>= return . graphFromEdges . triples - where - triples mp = map (\ (k, ks) -> (k, k, Set.toList ks)) $ Map.toList mp - -{- -type FieldType = (Int, Either StrictType VarStrictType) - --- | The information required to extact a field value from a value. --- We keep a stack of these as we traverse a declaration. Generally, --- we only need the field names. -data StackElement = StackElement FieldType Con Dec deriving (Eq, Show, Data, Typeable) - -class Monad m => HasStack m where - withStack :: ([StackElement] -> m a) -> m a -- Better name: askStack - push :: FieldType -> Con -> Dec -> m a -> m a -- Better name: localStack - -instance (Quasi m, Monoid w) => HasStack (RWST [StackElement] w s m) where - withStack f = ask >>= f - push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action - -instance HasStack m => HasStack (StateT s m) where - withStack f = lift (withStack return) >>= f - push fld con dec action = get >>= \ st -> lift $ push fld con dec (evalStateT action st) - -instance Quasi m => HasStack (ReaderT [StackElement] m) where - withStack f = ask >>= f - push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action - -instance (HasStack m, Monoid w) => HasStack (WriterT w m) where - withStack f = lift (withStack return) >>= f - push fld con dec action = - do (r, w') <- lift $ push fld con dec (runWriterT action) - tell w' - return r - -prettyStack :: [StackElement] -> String -prettyStack = prettyStack' . reverse - where - prettyStack' :: [StackElement] -> String - prettyStack' [] = "(empty)" - prettyStack' (x : xs) = "[" ++ prettyElt x ++ prettyTail xs ++ "]" - prettyTail [] = "" - prettyTail (x : xs) = " → " ++ prettyElt x ++ prettyTail xs - prettyElt (StackElement fld con dec) = - foldDec prettyType (\ _ -> nameBase (decName dec)) dec ++ ":" ++ - foldCon (\ name _ -> nameBase name) con ++ "." ++ - prettyField fld - prettyType typ = foldTypeP nameBase - (\ t1 t2 -> "((" ++ prettyType t1 ++ ") (" ++ prettyType t2 ++ "))") - ("(" ++ show typ ++ ")") - typ - -type StackT m = ReaderT [StackElement] m - -execStackT :: Monad m => StackT m a -> m a -execStackT action = runReaderT action [] - --- | Combine a decFn and a primFn to make a nameFn in the Quasi monad. --- This is used to build the first argument to the foldType function --- when we need to know whether the name refers to a declared or a --- primitive type. -foldName :: Quasi m => - (Dec -> m r) - -> (Name -> Int -> Bool -> m r) - -> (Info -> m r) - -> Name -> m r -foldName decFn primFn otherFn name = do - info <- qReify name - case info of - (TyConI dec) -> - decFn dec - (PrimTyConI a b c) -> primFn a b c - _ -> otherFn info - --- | Dispatch on the different constructors of the Dec type. -foldDec :: Monad m => - (Type -> m r) - -> ([Con] -> m r) - -> Dec -> m r -foldDec typeFn shapeFn dec = - case dec of - TySynD _name _ typ -> typeFn typ - NewtypeD _ _ _ con _ -> shapeFn [con] - DataD _ _ _ cons _ -> shapeFn cons - _ -> error $ "foldDec - unexpected: " ++ show dec - -decName :: Dec -> Name -decName (NewtypeD _ name _ _ _) = name -decName (DataD _ name _ _ _) = name -decName (TySynD name _ _) = name -decName x = error $ "decName - unimplemented: " ++ show x - --- | Deconstruct a constructor -foldCon :: (Name -> [FieldType] -> r) -> Con -> r -foldCon fldFn (NormalC name ts) = fldFn name $ zip [1..] (map Left ts) -foldCon fldFn (RecC name ts) = fldFn name (zip [1..] (map Right ts)) -foldCon fldFn (InfixC t1 name t2) = fldFn name [(1, Left t1), (2, Left t2)] -foldCon fldFn (ForallC _ _ con) = foldCon fldFn con - -prettyField :: FieldType -> String -prettyField fld = maybe (show (fPos fld)) nameBase (fName fld) - --- | Pure version of foldType. -foldTypeP :: (Name -> r) -> (Type -> Type -> r) -> r -> Type -> r -foldTypeP nfn afn ofn typ = runIdentity $ foldType (\ n -> Identity $ nfn n) (\ t1 t2 -> Identity $ afn t1 t2) (Identity ofn) typ - -fPos :: FieldType -> Int -fPos (n, _) = n - -fName :: FieldType -> Maybe Name -fName (_, (Left _)) = Nothing -fName (_, (Right (name, _, _))) = Just name - --- | Dispatch on the constructors of type Type. This ignores the --- "ForallT" constructor, it just uses the embeded Type field. -foldType :: Monad m => (Name -> m r) -> (Type -> Type -> m r) -> m r -> Type -> m r -foldType nfn afn ofn (ForallT _ _ typ) = foldType nfn afn ofn typ -foldType nfn _ _ (ConT name) = nfn name -foldType _ afn _ (AppT t1 t2) = afn t1 t2 -foldType _ _ ofn _ = ofn --} - -{- -adjacentTypes :: DsMonad m => Type -> m (Type, [Type]) -adjacentTypes (ForallT _ _ typ) = adjacentTypes typ -adjacentTypes (AppT t1 t2) = [t1, t2] -adjacentTypes t@(ConT _) = [t] -adjacentTypes t@(VarT _) = [t] -adjacentTypes _ = [] --} diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,18 +1,26 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-} module Common where +import Control.Lens ((%=), makeLenses, use) +import Control.Monad.State (evalStateT, StateT) import Data.List as List (map) import Data.Map as Map (toList) import Data.Set as Set (Set, difference, empty, toList) import Data.Generics (Data, everywhere, mkT) import Language.Haskell.TH -import Language.Haskell.TH.Context.Helpers (pprint') -import Language.Haskell.TH.TypeGraph (TypeGraphEdges) +import Language.Haskell.TH.Context (DecStatus(Declared, Undeclared), InstMap) +import Language.Haskell.TH.TypeGraph.Edges (GraphEdges) +import Language.Haskell.TH.TypeGraph.Expand (ExpandMap) +import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState)) +import Language.Haskell.TH.TypeGraph.Prelude (pprint') +import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), TGV) -data SetDifferences a = SetDifferences {extra :: Set a, missing :: Set a} deriving (Eq, Ord, Show) +data SetDifferences a = SetDifferences {unexpected :: Set a, missing :: Set a} deriving (Eq, Ord, Show) setDifferences :: Ord a => Set a -> Set a -> SetDifferences a -setDifferences actual expected = SetDifferences {extra = Set.difference actual expected, missing = Set.difference expected actual} -noDifferences = SetDifferences {extra = Set.empty, missing = Set.empty} +setDifferences actual expected = SetDifferences {unexpected = Set.difference actual expected, missing = Set.difference expected actual} +noDifferences :: SetDifferences a +noDifferences = SetDifferences {unexpected = Set.empty, missing = Set.empty} unReify :: Data a => a -> a unReify = everywhere (mkT unReifyName) @@ -29,11 +37,40 @@ pprintDec :: Dec -> String pprintDec = pprint' . unReify +pprintDec' :: DecStatus Dec -> String +pprintDec' (Undeclared x) = "Undeclared (" ++ pprint' (unReify x) ++ ")" +pprintDec' (Declared x) = "Declared (" ++ pprint' (unReify x) ++ ")" + pprintType :: Type -> String pprintType = pprint' . unReify +pprintVertex :: (Ppr v, TypeGraphVertex v) => v -> String +pprintVertex = pprint' + pprintPred :: Pred -> String pprintPred = pprint' . unReify -edgesToStrings :: TypeGraphEdges Type -> [(String, [String])] -edgesToStrings mp = List.map (\ (t, ts) -> (pprintType t, map pprintType (Set.toList ts))) (Map.toList mp) +edgesToStrings :: Ppr key => GraphEdges key -> [(String, [String])] +edgesToStrings mp = List.map (\ (t, ts) -> (pprint' t, map pprint' (Set.toList ts))) (Map.toList mp) + +data S + = S { _instMap :: InstMap + , _visited :: Set TGV + , _expanded :: ExpandMap } + +$(makeLenses ''S) + +instance Monad m => HasState InstMap (StateT S m) where + getState = use instMap + modifyState f = instMap %= f + +instance Monad m => HasState ExpandMap (StateT S m) where + getState = use expanded + modifyState f = expanded %= f + +instance Monad m => HasState (Set TGV) (StateT S m) where + getState = use visited + modifyState f = visited %= f + +evalS :: Monad m => StateT S m a -> m a +evalS action = evalStateT action (S mempty mempty mempty) diff --git a/test/Context.hs b/test/Context.hs --- a/test/Context.hs +++ b/test/Context.hs @@ -5,19 +5,22 @@ module Context where import Control.DeepSeq +import Control.Lens (view) +import Control.Monad.State (evalStateT, runStateT) import Data.Array.IArray import Data.Array.Unboxed import Data.Bits -import Data.List as List (map, null) -import Data.Map as Map (Map, map, mapKeys, toList, fromList) -import Data.Set as Set (Set, fromList) +import Data.List as List (map) +import Data.Map as Map (Map, empty, map, mapKeys, toList, fromList) +import Data.Set as Set (fromList, map, Set) import Language.Haskell.TH -import Language.Haskell.TH.Context (reifyInstancesWithContext, runContext) -import Language.Haskell.TH.Context.Expand (expandType) -import Language.Haskell.TH.Context.Helpers (pprint') -import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest) +import Language.Haskell.TH.Context (reifyInstancesWithContext, expandType) +-- import Language.Haskell.TH.Context.S (S(S), instMap) +-- import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest) import Language.Haskell.TH.Desugar (withLocalDeclarations) import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReifyInstances)) +import Language.Haskell.TH.TypeGraph.Expand (E(unE), ExpandMap) +import Language.Haskell.TH.TypeGraph.Prelude (pprint') import System.Exit (ExitCode) import Test.Hspec hiding (runIO) import Test.Hspec.Core.Spec (SpecM) @@ -34,9 +37,10 @@ -- String becomes [Char], Maybe String becomes Maybe [Char], Maybe (Maybe String) becomes Maybe (Maybe [Char]) it "expands types as expected" $ do (expected :: [Type]) <- runQ (sequence [ [t| [Char] |], [t|Maybe [Char] |], [t|Maybe (Maybe [Char])|] ]) - let expanded = $(withLocalDeclarations [] (do (types :: [Type]) <- runQ (sequence [ [t|String|], [t|Maybe String|], [t|Maybe (Maybe String)|] ]) >>= mapM expandType - runQ . lift $ types)) - expanded `shouldBe` expected + let actual = $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $ + do (types :: [Type]) <- runQ (sequence [ [t|String|], [t|Maybe String|], [t|Maybe (Maybe String)|] ]) >>= mapM expandType >>= return . List.map unE + runQ . lift $ types) + actual `shouldBe` expected -- Test the behavior of th-reify-many it "can tell that there is an instance NFData Char" $ @@ -46,7 +50,7 @@ it "can tell that there is no instance NFData ExitCode" $ $(do insts <- qReifyInstances ''NFData [ConT ''ExitCode] lift $ List.map pprint' insts) `shouldBe` ([] :: [String]) - +{- it "can tell that an instance hasn't been declared" $ $(missingInstances simpleMissingInstanceTest [d|instance NFData ExitCode|] >>= lift . List.null) `shouldBe` False @@ -54,14 +58,13 @@ it "can tell that an instance has been declared" $ $(missingInstances simpleMissingInstanceTest [d|instance NFData Char|] >>= lift . List.null) `shouldBe` True - +-} -- GHCs older than 7.10 that haven't been specially patched cannot deal with -- the unbound type variable a. -#if __GLASGOW_HASKELL__ >= 709 || defined(PATCHED_FOR_TRAC_9262) -- Doesn't actually use any th-context functions, but it tests -- for trac 9262. it "Is using a ghc without bug https://ghc.haskell.org/trac/ghc/ticket/9262 (i.e. either 7.10 or a custom patched ghc)" $ do - $(do insts <- qReifyInstances ''Eq [ListT `AppT` VarT (mkName "a")] + $(do _insts <- qReifyInstances ''Eq [ListT `AppT` VarT (mkName "a")] -- runIO $ putStrLn (pprint insts) lift "ok") `shouldBe` "ok" @@ -85,10 +88,22 @@ Map.map Set.fromList (Map.fromList pairs))) -- Unquote the template haskell Q monad expression $(do -- Run instances and save the result and the state monad result - (insts, mp) <- runContext (reifyInstancesWithContext ''IArray [ConT ''UArray, VarT (mkName "a")]) + (insts, s) <- runStateT (reifyInstancesWithContext ''IArray [ConT ''UArray, VarT (mkName "a")]) (S mempty mempty mempty) -- Convert to lists of text so we can lift out of Q - lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec) (Map.mapKeys pprintPred mp)))) + lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . unE) (view instMap s))))) `shouldBe` (noDifferences, -- I don't think this is right - Map.fromList [{-("Data.Array.Base.IArray Data.Array.Base.UArray a", arrayInstances)-}] :: Map String (Set String)) -#endif + Map.fromList [("IArray UArray a", Set.map (\ x -> "Declared (" ++ x ++ ")") arrayInstances)] :: Map String (Set String)) + + it "handles a wrapper instance" $ + $(do (insts, s) <- runStateT (reifyInstancesWithContext ''MyClass [AppT (ConT ''Wrapper) (ConT ''Int)]) (S mempty mempty mempty) + lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . unE) (view instMap s))))) + `shouldBe` (["instance MyClass a => MyClass (Wrapper a)"], + [("MyClass (Wrapper Int)",["Declared (instance MyClass a => MyClass (Wrapper a))"]), + ("MyClass Int",["Declared (instance MyClass Int)"])]) + it "handles a multi param wrapper instance" $ + $(do (insts, s) <- runStateT (reifyInstancesWithContext ''MyMPClass [VarT (mkName "a"), AppT (ConT ''Wrapper) (ConT ''Int)]) (S mempty mempty mempty) + lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . unE) (view instMap s))))) + `shouldBe` (["instance MyMPClass a b => MyMPClass a (Wrapper b)"], + [("MyMPClass a (Wrapper Int)",["Declared (instance MyMPClass a b => MyMPClass a (Wrapper b))"]), + ("MyMPClass a Int",["Declared (instance MyMPClass a Int)"])]) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,28 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where -import Control.DeepSeq -import Control.Monad.State (evalStateT, runStateT) -import Data.Array.Base -import Data.ByteString (ByteString) -import Data.List as List (intercalate, map, null) -import Data.Map as Map (Map, fromList, toList, map, mapKeys, empty) -import Data.Set as Set (Set, fromList, toList, null, difference, empty) -import Data.Text (Text) -import Data.Monoid (mempty) -import Language.Haskell.TH -import Language.Haskell.TH.Context (reifyInstancesWithContext) -import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest) -import Language.Haskell.TH.Desugar (withLocalDeclarations) -import Language.Haskell.TH.ReifyMany -import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReifyInstances)) -import System.Exit (ExitCode) import Test.Hspec hiding (runIO) import Context (tests) -import TypeGraph (tests) main :: IO () main = hspec $ do - TypeGraph.tests Context.tests diff --git a/test/TypeGraph.hs b/test/TypeGraph.hs deleted file mode 100644 --- a/test/TypeGraph.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} -module TypeGraph where - -import Control.Monad (filterM) ---import Data.Map as Map (toList) -import Data.Set as Set (fromList, toList) ---import GHC.Prim -- ByteArray#, Char#, etc -import Language.Haskell.TH -import Language.Haskell.TH.Desugar (withLocalDeclarations) -import Language.Haskell.TH.Context.Expand (expandType) -import Language.Haskell.TH.Context.Helpers (typeArity) -import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.TypeGraph (typeGraphVertices, typeGraphEdges, VertexStatus(Vertex)) -import Test.Hspec hiding (runIO) -import Test.Hspec.Core.Spec (SpecM) - -import Common -import Values - -tests :: SpecM () () -tests = do - it "can find the subtypes of Type" $ do - setDifferences (fromList $(withLocalDeclarations [] $ - runQ [t|Type|] >>= - expandType >>= \ (typ :: Type) -> - typeGraphVertices (const $ return Vertex) [typ] >>= - runQ . lift . map pprintType . Set.toList)) subtypesOfType - `shouldBe` noDifferences - - it "can find the edges of the subtype graph of Type" $ do - setDifferences (fromList $(withLocalDeclarations [] $ - runQ [t|Type|] >>= - expandType >>= \ (typ :: Type) -> - typeGraphEdges (const $ return Vertex) [typ] >>= - runQ . lift . edgesToStrings)) typeEdges - `shouldBe` noDifferences - - it "can find the edges of the subtype graph of Dec" $ do - setDifferences (fromList $(withLocalDeclarations [] $ - runQ [t|Dec|] >>= - expandType >>= \ (typ :: Type) -> - typeGraphEdges (const $ return Vertex) [typ] >>= - runQ . lift . edgesToStrings)) decEdges - `shouldBe` noDifferences - - it "can find the subtypes of Dec" $ do - setDifferences (fromList $(withLocalDeclarations [] $ - runQ [t|Dec|] >>= - expandType >>= \ (typ :: Type) -> - typeGraphVertices (const $ return Vertex) [typ] >>= - runQ . lift . map pprintType . Set.toList)) subtypesOfDec - `shouldBe` noDifferences - - it "can find the arity 0 subtypes of Dec" $ do - setDifferences (fromList $(withLocalDeclarations [] $ - runQ [t|Dec|] >>= - expandType >>= \ (typ :: Type) -> - typeGraphVertices (const $ return Vertex) [typ] >>= - filterM (\ t -> typeArity t >>= \ a -> return (a == 0)) . Set.toList >>= - runQ . lift . map pprintType)) arity0SubtypesOfDec - `shouldBe` noDifferences diff --git a/test/Values.hs b/test/Values.hs --- a/test/Values.hs +++ b/test/Values.hs @@ -1,115 +1,55 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Values where -import Control.Monad (filterM) -import Data.Map as Map (toList) -import Data.Set as Set (Set, fromList, toList, union) -import GHC.Prim -- ByteArray#, Char#, etc -import Language.Haskell.TH -import Language.Haskell.TH.Desugar (withLocalDeclarations) -import Language.Haskell.TH.Context.Expand (expandType) -import Language.Haskell.TH.Context.Helpers (typeArity) +import Data.Set as Set (Set, fromList) import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.TypeGraph (typeGraphVertices, typeGraphEdges, VertexStatus(Vertex)) -import Test.Hspec hiding (runIO) -import Test.Hspec.Core.Spec (SpecM) -import Common - -subtypesOfType :: Set String -subtypesOfType = - fromList - [ -#if MIN_VERSION_template_haskell(2,10,0) - "BigNat", -#else - "[Type]", -#endif - "ByteArray#","Char","Char#","Cxt","Int","Int#","Integer","Kind","ModName","Name","NameFlavour","NameSpace","OccName","PkgName","Pred","String","TyLit","TyVarBndr","Type","[Char]","[Pred]","[TyVarBndr]", "[]" ] - -decEdges :: Set (String, [String]) -decEdges = - fromList - [ -#if MIN_VERSION_template_haskell(2,10,0) - ("BigNat",["ByteArray#"]), - ("Integer",["Int#","BigNat"]), - ("NameFlavour",["Int","ModName","NameSpace","PkgName"]), - ("Pragma",["Maybe Inline","[RuleBndr]","String","Int","AnnTarget","Exp","Inline","Name","Phases","RuleMatch","Type"]), - ("Pred",["Type"]), -#else - ("Integer",["ByteArray#","Int#"]), - ("NameFlavour",["Int#","ModName","NameSpace","PkgName"]), - ("Pragma",["Maybe Inline","[RuleBndr]","String","AnnTarget","Exp","Inline","Name","Phases","RuleMatch","Type"]), - ("Pred",["[Type]","Name","Type"]), -#endif - ("(,)",[]),("(,,)",[]),("[]",[]),("(,) Guard",["Guard","(,)"]),("(,) Name",["Name","(,)"]),("(,) Strict",["Strict","(,)"]),("(,,) Name",["Name","(,,)"]),("(,,) Name Strict",["(,,) Name","Strict"]),("(Guard, Exp)",["(,) Guard","Exp"]),("(Name, Exp)",["(,) Name","Exp"]),("(Name, Pat)",["(,) Name","Pat"]),("(Name, Strict, Type)",["(,,) Name Strict","Type"]),("(Strict, Type)",["(,) Strict","Type"]),("AnnTarget",["Name"]),("Body",["[(Guard, Exp)]","Exp"]),("ByteArray#",[]),("Callconv",[]),("Char",["Char#"]),("Char#",[]),("Clause",["[Dec]","[Pat]","Body"]),("Con",["[StrictType]","[TyVarBndr]","[VarStrictType]","Con","Cxt","Name","StrictType"]),("Cxt",["[Pred]"]),("Dec",["Maybe Kind","[Clause]","[Con]","[Dec]","[FunDep]","[Name]","[Role]","[TySynEqn]","[TyVarBndr]","[Type]","Body","Con","Cxt","FamFlavour","Fixity","Foreign","Name","Pat","Pragma","TySynEqn","Type"]),("Exp",["Maybe Exp","[(Guard, Exp)]","[Dec]","[Exp]","[FieldExp]","[Match]","[Pat]","[Stmt]","Exp","Lit","Name","Range","Type"]),("FamFlavour",[]),("FieldExp",["(Name, Exp)"]),("FieldPat",["(Name, Pat)"]),("Fixity",["Int","FixityDirection"]),("FixityDirection",[]),("Foreign",["String","Callconv","Name","Safety","Type"]),("FunDep",["[Name]"]),("Guard",["[Stmt]","Exp"]),("Inline",[]),("Int",["Int#"]),("Int#",[]),("Kind",["Type"]),("Lit",["[Word8]","String","Rational","Char","Integer"]),("Match",["[Dec]","Body","Pat"]),("Maybe",["a"]),("Maybe Exp",["Maybe","Exp"]),("Maybe Inline",["Maybe","Inline"]),("Maybe Kind",["Maybe","Kind"]),("ModName",["String"]),("Name",["NameFlavour","OccName"]),("NameSpace",[]),("OccName",["String"]),("Pat",["[FieldPat]","[Pat]","Exp","Lit","Name","Pat","Type"]),("Phases",["Int"]),("PkgName",["String"]),("Range",["Exp"]),("Ratio",["a"]),("Ratio Integer",["Ratio","Integer"]),("Rational",["Ratio Integer"]),("Role",[]),("RuleBndr",["Name","Type"]),("RuleMatch",[]),("Safety",[]),("Stmt",["[[Stmt]]","[Dec]","Exp","Pat"]),("Strict",[]),("StrictType",["(Strict, Type)"]),("String",["[Char]"]),("TyLit",["String","Integer"]),("TySynEqn",["[Type]","Type"]),("TyVarBndr",["Kind","Name"]),("Type",["[TyVarBndr]","Int","Cxt","Kind","Name","TyLit","Type"]),("VarStrictType",["(Name, Strict, Type)"]),("Word#",[]),("Word8",["Word#"]),("[(Guard, Exp)]",["(Guard, Exp)","[]"]),("[Char]",["Char","[]"]),("[Clause]",["Clause","[]"]),("[Con]",["Con","[]"]),("[Dec]",["Dec","[]"]),("[Exp]",["Exp","[]"]),("[FieldExp]",["FieldExp","[]"]),("[FieldPat]",["FieldPat","[]"]),("[FunDep]",["FunDep","[]"]),("[Match]",["Match","[]"]),("[Name]",["Name","[]"]),("[Pat]",["Pat","[]"]),("[Pred]",["Pred","[]"]),("[Role]",["Role","[]"]),("[RuleBndr]",["RuleBndr","[]"]),("[Stmt]",["Stmt","[]"]),("[StrictType]",["StrictType","[]"]),("[TySynEqn]",["TySynEqn","[]"]),("[TyVarBndr]",["TyVarBndr","[]"]),("[Type]",["Type","[]"]),("[VarStrictType]",["VarStrictType","[]"]),("[Word8]",["Word8","[]"]),("[[Stmt]]",["[Stmt]","[]"]),("a",[])] - -typeEdges :: Set (String, [String]) -typeEdges = - fromList - [ -#if MIN_VERSION_template_haskell(2,10,0) - ("BigNat",["ByteArray#"]), - ("Integer",["Int#","BigNat"]), - ("NameFlavour",["Int","ModName","NameSpace","PkgName"]),("Pred",["Type"]), -#else - ("Integer",["ByteArray#","Int#"]), - ("NameFlavour",["Int#","ModName","NameSpace","PkgName"]), - ("Pred",["[Type]","Name","Type"]),("[Type]",["Type","[]"]), -#endif - ("[]",[]),("ByteArray#",[]),("Char",["Char#"]),("Char#",[]),("Cxt",["[Pred]"]),("Int",["Int#"]),("Int#",[]),("Kind",["Type"]),("ModName",["String"]),("Name",["NameFlavour","OccName"]),("NameSpace",[]),("OccName",["String"]),("PkgName",["String"]),("String",["[Char]"]),("TyLit",["String","Integer"]),("TyVarBndr",["Kind","Name"]),("Type",["[TyVarBndr]","Int","Cxt","Kind","Name","TyLit","Type"]),("[Char]",["Char","[]"]),("[Pred]",["Pred","[]"]),("[TyVarBndr]",["TyVarBndr","[]"])] - -arity0SubtypesOfDec :: Set String -arity0SubtypesOfDec = - fromList - [ -#if MIN_VERSION_template_haskell(2,10,0) - "BigNat", -#endif - "(Guard, Exp)","(Name, Exp)","(Name, Pat)","(Name, Strict, Type)","(Strict, Type)","AnnTarget","Body","ByteArray#","Callconv","Char","Char#","Clause","Con","Cxt","Dec","Exp","FamFlavour","FieldExp","FieldPat","Fixity","FixityDirection","Foreign","FunDep","Guard","Inline","Int","Int#","Integer","Kind","Lit","Match","Maybe Exp","Maybe Inline","Maybe Kind","ModName","Name","NameFlavour","NameSpace","OccName","Pat","Phases","PkgName","Pragma","Pred","Range","Ratio Integer","Rational","Role","RuleBndr","RuleMatch","Safety","Stmt","Strict","StrictType","String","TyLit","TySynEqn","TyVarBndr","Type","VarStrictType","Word#","Word8","[(Guard, Exp)]","[Char]","[Clause]","[Con]","[Dec]","[Exp]","[FieldExp]","[FieldPat]","[FunDep]","[Match]","[Name]","[Pat]","[Pred]","[Role]","[RuleBndr]","[Stmt]","[StrictType]","[TySynEqn]","[TyVarBndr]","[Type]","[VarStrictType]","[Word8]","[[Stmt]]" ] - - -subtypesOfDec :: Set String -subtypesOfDec = - union - arity0SubtypesOfDec - (fromList - [ - "a", - "Maybe", - "Ratio", - "(,) Guard", - "(,) Name", - "(,) Strict", - "(,,) Name", - "(,,) Name Strict", - "(,,)", - "(,)", - "[]"]) - bitsInstances :: Set String -bitsInstances - = Set.fromList - [ -#if MIN_VERSION_template_haskell(2,10,0) - "instance Bits CChar","instance Bits CInt","instance Bits CIntMax","instance Bits CIntPtr","instance Bits CLLong","instance Bits CLong","instance Bits CPtrdiff","instance Bits CSChar","instance Bits CShort","instance Bits CSigAtomic","instance Bits CSize","instance Bits CUChar","instance Bits CUInt","instance Bits CUIntMax","instance Bits CUIntPtr","instance Bits CULLong","instance Bits CULong","instance Bits CUShort","instance Bits CWchar", -#endif - "instance Bits Bool","instance Bits Int","instance Bits Integer","instance Bits Word","instance Bits Word16","instance Bits Word32","instance Bits Word64","instance Bits Word8", - -- These come and go depending on the version of something. - "instance Bits Int16","instance Bits Int32","instance Bits Int64","instance Bits Int8","instance Bits Natural" ] +bitsInstances = + Set.fromList + [ + "instance Bits CChar","instance Bits CInt","instance Bits CIntMax","instance Bits CIntPtr","instance Bits CLLong","instance Bits CLong","instance Bits CPtrdiff","instance Bits CSChar","instance Bits CShort","instance Bits CSigAtomic","instance Bits CSize","instance Bits CUChar","instance Bits CUInt","instance Bits CUIntMax","instance Bits CUIntPtr","instance Bits CULLong","instance Bits CULong","instance Bits CUShort","instance Bits CWchar", + "instance Bits Bool","instance Bits Int","instance Bits Integer","instance Bits Word","instance Bits Word16","instance Bits Word32","instance Bits Word64","instance Bits Word8", + -- These come and go depending on the version of something. + "instance Bits Int16","instance Bits Int32","instance Bits Int64","instance Bits Int8","instance Bits Natural" + ] enumInstances :: Set String enumInstances = - Set.fromList + Set.fromList [ -#if MIN_VERSION_template_haskell(2,10,0) - "instance Enum (Fixed a)","instance Enum (Proxy s)","instance Enum (f a) => Enum (Alt f a)","instance Enum CChar","instance Enum CClock","instance Enum CDouble","instance Enum CFloat","instance Enum CInt","instance Enum CIntMax","instance Enum CIntPtr","instance Enum CLLong","instance Enum CLong","instance Enum CPtrdiff","instance Enum CSChar","instance Enum CSUSeconds","instance Enum CShort","instance Enum CSigAtomic","instance Enum CSize","instance Enum CTime","instance Enum CUChar","instance Enum CUInt","instance Enum CUIntMax","instance Enum CUIntPtr","instance Enum CULLong","instance Enum CULong","instance Enum CUSeconds","instance Enum CUShort","instance Enum CWchar","instance Enum Day","instance Enum NominalDiffTime", -#endif - "instance Enum ()","instance Enum Bool","instance Enum Char","instance Enum Double","instance Enum Float","instance Enum Int","instance Enum Int16","instance Enum Int32","instance Enum Int64","instance Enum Int8","instance Enum Integer","instance Enum Natural","instance Enum Ordering","instance Enum Word","instance Enum Word16","instance Enum Word32","instance Enum Word64","instance Enum Word8","instance Integral a => Enum (Ratio a)"] + "instance Enum (Fixed a)","instance Enum (Proxy s)","instance Enum (f a) => Enum (Alt f a)","instance Enum CChar","instance Enum CClock","instance Enum CDouble","instance Enum CFloat","instance Enum CInt","instance Enum CIntMax","instance Enum CIntPtr","instance Enum CLLong","instance Enum CLong","instance Enum CPtrdiff","instance Enum CSChar","instance Enum CSUSeconds","instance Enum CShort","instance Enum CSigAtomic","instance Enum CSize","instance Enum CTime","instance Enum CUChar","instance Enum CUInt","instance Enum CUIntMax","instance Enum CUIntPtr","instance Enum CULLong","instance Enum CULong","instance Enum CUSeconds","instance Enum CUShort","instance Enum CWchar","instance Enum Day","instance Enum NominalDiffTime", + "instance Enum ()","instance Enum Bool","instance Enum Char","instance Enum Double","instance Enum Float","instance Enum Int","instance Enum Int16","instance Enum Int32","instance Enum Int64","instance Enum Int8","instance Enum Integer","instance Enum Natural","instance Enum Ordering","instance Enum Word","instance Enum Word16","instance Enum Word32","instance Enum Word64","instance Enum Word8","instance Integral a => Enum (Ratio a)" + ] arrayInstances :: Set String arrayInstances = - Set.fromList ["instance IArray UArray (FunPtr a)","instance IArray UArray (Ptr a)","instance IArray UArray (StablePtr a)","instance IArray UArray Bool","instance IArray UArray Char","instance IArray UArray Double","instance IArray UArray Float","instance IArray UArray Int","instance IArray UArray Int16","instance IArray UArray Int32","instance IArray UArray Int64","instance IArray UArray Int8","instance IArray UArray Word","instance IArray UArray Word16","instance IArray UArray Word32","instance IArray UArray Word64","instance IArray UArray Word8"] + Set.fromList ["instance IArray UArray (FunPtr a)", + "instance IArray UArray (Ptr a)", + "instance IArray UArray (StablePtr a)", + "instance IArray UArray Bool", + "instance IArray UArray Char", + "instance IArray UArray Double", + "instance IArray UArray Float", + "instance IArray UArray Int", + "instance IArray UArray Int16", + "instance IArray UArray Int32", + "instance IArray UArray Int64", + "instance IArray UArray Int8", + "instance IArray UArray Word", + "instance IArray UArray Word16", + "instance IArray UArray Word32", + "instance IArray UArray Word64", + "instance IArray UArray Word8"] + +class MyClass a +class MyMPClass a b +data Wrapper a = Wrapper a + +instance MyClass Int +instance MyClass a => MyClass (Wrapper a) + +instance MyMPClass a Int +instance MyMPClass a b => MyMPClass a (Wrapper b) diff --git a/th-context.cabal b/th-context.cabal --- a/th-context.cabal +++ b/th-context.cabal @@ -1,5 +1,5 @@ name: th-context -version: 0.13 +version: 0.20 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -14,44 +14,38 @@ description: Use these functions to decide an a not-quite naive fashion whether an instance already exists that satisfies a given context. This can be used to decide whether an instance - needs to be generated, as in th-reify-many. -extra-source-files: test/Common.hs test/Context.hs test/Tests.hs test/TypeGraph.hs test/Values.hs - -flag patched-for-trac-9262 - Description: This can be turned on if ghc-7.8 has had a patch applied to fix issue 9262 - Default: True + needs to be generated, as in th-reify-many. Known limitation: + the instances inserted into the InstMap are not fully recognized + when computing the context. +extra-source-files: test/Common.hs test/Context.hs test/Tests.hs test/Values.hs -library +Library + hs-source-dirs: . build-depends: - base >= 4.2 && < 5, + base >= 4.8 && < 5, containers, data-default, haskell-src-exts, + lens, mtl, syb, - template-haskell >= 2.9, + template-haskell >= 2.10, th-desugar, - th-orphans >= 0.10.0 - ghc-options: -Wall - exposed-modules: Language.Haskell.TH.Context, - Language.Haskell.TH.Context.Expand, - Language.Haskell.TH.Context.Helpers, - Language.Haskell.TH.Context.Simple, - Language.Haskell.TH.TypeGraph + th-orphans >= 0.10.0, + th-typegraph >= 0.24 + ghc-options: -Wall -O2 + exposed-modules: Language.Haskell.TH.Context default-language: Haskell2010 - if flag(patched-for-trac-9262) - cpp-options: -DPATCHED_FOR_TRAC_9262 test-suite th-context-tests type: exitcode-stdio-1.0 + ghc-options: -Wall -O2 hs-source-dirs: test main-is: Tests.hs build-depends: array, base, bytestring, containers, deepseq, ghc-prim, - hspec, hspec-core, mtl, syb, template-haskell, text, - th-context, th-desugar, th-orphans, th-reify-many + hspec, hspec-core, lens, mtl, syb, template-haskell, text, + th-context >= 0.19, th-desugar, th-orphans, th-reify-many, th-typegraph >= 0.23 default-language: Haskell2010 - if flag(patched-for-trac-9262) - cpp-options: -DPATCHED_FOR_TRAC_9262 source-repository head type: git