th-context 0.20 → 0.20.1
raw patch · 4 files changed
+31/−37 lines, 4 filesdep +mtl-unleasheddep ~th-typegraph
Dependencies added: mtl-unleashed
Dependency ranges changed: th-typegraph
Files
- Language/Haskell/TH/Context.hs +14/−20
- test/Common.hs +11/−12
- test/Context.hs +2/−2
- th-context.cabal +4/−3
Language/Haskell/TH/Context.hs view
@@ -25,7 +25,7 @@ import Data.Maybe (isJust) import Control.Monad (filterM)-import Control.Monad.State (get, modify, StateT)+import Control.Monad.States (MonadStates, get, modify) import Control.Monad.Writer (MonadWriter, tell) import Data.Generics (everywhere, mkT) import Data.List (intercalate)@@ -37,7 +37,6 @@ 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 -}) -- FIXME: Should actually be Map (E Pred) (Maybe (DecStatus@@ -66,25 +65,25 @@ -- 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 :: forall m. (DsMonad m, HasState InstMap m, HasState ExpandMap m) =>+reifyInstancesWithContext :: forall m. (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => Name -> [Type] -> m [InstanceDec] reifyInstancesWithContext className typeParameters = do p <- expandType $ foldInstance className typeParameters- mp <- getState :: m InstMap+ mp <- get :: 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)+ modify (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))+ modify (Map.insert p (map Declared r)) -- trace (" <- reifyInstancesWithContext " ++ pprint (foldInstance className typeParameters) ++ " -> " ++ pprint r) (return ()) return r @@ -92,7 +91,7 @@ -- 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, HasState InstMap m, HasState ExpandMap m) => Name -> [Type] -> InstanceDec -> m Bool+testInstance :: (DsMonad m, MonadStates InstMap m, MonadStates 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@@ -113,13 +112,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, HasState InstMap m, HasState ExpandMap m) => [Pred] -> m Bool+testContext :: (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => [Pred] -> m Bool testContext context = and <$> (simplifyContext context >>= mapM consistent) -- | Perform type expansion on the predicates, then simplify using -- variable substitution and eliminate vacuous equivalences.-simplifyContext :: (DsMonad m, HasState InstMap m) => [Pred] -> m [Pred]+simplifyContext :: (DsMonad m, MonadStates InstMap m) => [Pred] -> m [Pred] simplifyContext context = do let context' = concat $ map unify context let context'' = foldl simplifyPredicate context' context'@@ -145,7 +144,7 @@ -- | Decide whether a predicate is consistent with the accumulated -- context. Use recursive calls to reifyInstancesWithContext when -- we encounter a class name applied to a list of type parameters.-consistent :: (DsMonad m, HasState InstMap m, HasState ExpandMap m) => Pred -> m Bool+consistent :: (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => Pred -> m Bool consistent typ | isJust (unfoldInstance typ) = let Just (className, typeParameters) = unfoldInstance typ in@@ -163,32 +162,27 @@ -- this, the instance predicate (constructed from class name and type -- parameters) will be considered part of the context for subsequent -- calls to reifyInstancesWithContext.-tellInstance :: (DsMonad m, HasState InstMap m, Quasi m, HasState ExpandMap m) => Dec -> m ()+tellInstance :: (DsMonad m, MonadStates InstMap m, Quasi m, MonadStates ExpandMap m) => Dec -> m () tellInstance inst@(InstanceD _ instanceType _) = do let Just (className, typeParameters) = unfoldInstance instanceType p <- expandType $ foldInstance className typeParameters- (mp :: InstMap) <- getState+ (mp :: InstMap) <- get case Map.lookup p mp of Just (_ : _) -> return () -- 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])+ _ -> modify (Map.insert p [Undeclared inst]) tellInstance inst = error $ "tellInstance - Not an instance: " ++ pprint inst --- A basic HasState InstMap instance.-instance Monad m => HasState InstMap (StateT InstMap m) where- getState = get- modifyState = modify- -- | 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 :: (MonadWriter [Dec] m, MonadStates InstMap m) => m () tellUndeclared =- getState >>= \(mp :: InstMap) -> tell . mapMaybe undeclared . concat . Map.elems $ mp+ get >>= \(mp :: InstMap) -> tell . mapMaybe undeclared . concat . Map.elems $ mp where undeclared :: DecStatus Dec -> Maybe Dec undeclared (Undeclared dec) = Just dec
test/Common.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-} module Common where -import Control.Lens ((%=), makeLenses, use)-import Control.Monad.State (evalStateT, StateT)+import Control.Lens (makeLenses, use, (.=))+import Control.Monad.States (evalStateT, MonadStates(get, put), StateT) import Data.List as List (map) import Data.Map as Map (toList) import Data.Set as Set (Set, difference, empty, toList)@@ -11,7 +11,6 @@ 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) @@ -60,17 +59,17 @@ $(makeLenses ''S) -instance Monad m => HasState InstMap (StateT S m) where- getState = use instMap- modifyState f = instMap %= f+instance Monad m => MonadStates InstMap (StateT S m) where+ get = use instMap+ put s = instMap .= s -instance Monad m => HasState ExpandMap (StateT S m) where- getState = use expanded- modifyState f = expanded %= f+instance Monad m => MonadStates ExpandMap (StateT S m) where+ get = use expanded+ put s = expanded .= s -instance Monad m => HasState (Set TGV) (StateT S m) where- getState = use visited- modifyState f = visited %= f+instance Monad m => MonadStates (Set TGV) (StateT S m) where+ get = use visited+ put s = visited .= s evalS :: Monad m => StateT S m a -> m a evalS action = evalStateT action (S mempty mempty mempty)
test/Context.hs view
@@ -14,12 +14,12 @@ 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, expandType)+import Language.Haskell.TH.Context (reifyInstancesWithContext) -- 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.Expand (E(unE), ExpandMap, expandType) import Language.Haskell.TH.TypeGraph.Prelude (pprint') import System.Exit (ExitCode) import Test.Hspec hiding (runIO)
th-context.cabal view
@@ -1,5 +1,5 @@ name: th-context-version: 0.20+version: 0.20.1 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -28,11 +28,12 @@ haskell-src-exts, lens, mtl,+ mtl-unleashed >= 0.2.1, syb, template-haskell >= 2.10, th-desugar, th-orphans >= 0.10.0,- th-typegraph >= 0.24+ th-typegraph >= 0.25 ghc-options: -Wall -O2 exposed-modules: Language.Haskell.TH.Context default-language: Haskell2010@@ -44,7 +45,7 @@ main-is: Tests.hs build-depends: array, base, bytestring, containers, deepseq, ghc-prim, hspec, hspec-core, lens, mtl, syb, template-haskell, text,- th-context >= 0.19, th-desugar, th-orphans, th-reify-many, th-typegraph >= 0.23+ th-context >= 0.19, th-desugar, th-orphans, th-reify-many, th-typegraph >= 0.25 default-language: Haskell2010 source-repository head