module Language.Haskell.TH.TypeGraph.TypeGraph
( TypeGraph, graph, gsimple, stack
, makeTypeGraph
, graphFromMap
, HasTGV(asTGV)
, HasTGVSimple(asTGVSimple)
, simplify
, allPathNodes
, allPathStarts
, lensKeys, allLensKeys
, tgv, tgvSimple, tgvSimple'
, pathKeys, pathKeys', allPathKeys
, reachableFrom
, reachableFromSimple
, goalReachableFull
, goalReachableSimple
, goalReachableSimple'
, VertexStatus(..)
, typeGraphVertex
, typeGraphVertexOfField
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
import Data.Monoid (mempty)
#else
import Control.Applicative
#endif
import Control.Lens
import Control.Monad (foldM)
import qualified Control.Monad.Reader as MTL (ask, ReaderT, runReaderT)
import Control.Monad.Readers (MonadReaders(askPoly, localPoly))
import Control.Monad.States (MonadStates)
import Control.Monad.Trans (lift)
import Data.Default (Default(def))
import Data.Foldable as Fold
import Data.Graph hiding (edges)
import Data.List as List (map)
import Data.Map.Strict as Map (insertWith, Map)
import qualified Data.Map.Strict as Map (toList)
import Data.Maybe (fromJust, mapMaybe)
import Data.Set.Extra as Set (empty, fromList, map, mapM, Set, singleton, toList, union)
import Data.Traversable as Traversable
import Language.Haskell.Exts.Syntax ()
import Language.Haskell.TH
import Language.Haskell.TH.Desugar (DsMonad)
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.PprLib (ptext, vcat)
import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges)
import Language.Haskell.TH.Expand (ExpandMap, expandType)
import Language.Haskell.TH.TypeGraph.Prelude (adjacent', pprint1, reachable')
import Language.Haskell.TH.TypeGraph.TypeInfo (startTypes, TypeInfo, typeVertex, typeVertex', fieldVertex)
import Language.Haskell.TH.TypeGraph.Shape (Field)
import Language.Haskell.TH.TypeGraph.Stack (StackElement)
import Language.Haskell.TH.TypeGraph.Vertex (TGV'(..), TGV, TGVSimple'(..), TGVSimple, TypeGraphVertex, vsimple)
import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or)
data TypeGraph
= TypeGraph
{ _graph :: (Graph, Vertex -> ((), TGV', [TGV']), TGV' -> Maybe Vertex)
, _gsimple :: (Graph, Vertex -> ((), TGVSimple', [TGVSimple']), TGVSimple' -> Maybe Vertex)
, _stack :: [StackElement]
}
makeTypeGraph :: MonadReaders TypeInfo m => (GraphEdges TGV') -> m TypeGraph
makeTypeGraph es = do
return $ TypeGraph
{ _graph = graphFromMap es
, _gsimple = graphFromMap (simpleEdges es)
, _stack = []
}
graphFromMap :: forall key. (Ord key) =>
GraphEdges key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex)
graphFromMap mp =
graphFromEdges triples
where
triples :: [((), key, [key])]
triples = List.map (\ (k, ks) -> ((), k, Fold.toList ks)) $ Map.toList mp
$(makeLenses ''TypeGraph)
instance (Monad m, MonadReaders [StackElement] m) => MonadReaders [StackElement] (MTL.ReaderT TypeGraph m) where
askPoly = lift askPoly
localPoly f action = MTL.ask >>= MTL.runReaderT (localPoly f (lift action))
instance MonadReaders TypeInfo m => MonadReaders TypeInfo (MTL.ReaderT TypeGraph m) where
askPoly = lift askPoly
localPoly f action = MTL.ask >>= MTL.runReaderT (localPoly f (lift action))
instance Ppr TypeGraph where
ppr = ppr . view graph
instance Ppr Vertex where
ppr n = ptext ("V" ++ show n)
instance Ppr (Graph, Vertex -> ((), TGV', [TGV']), TGV' -> Maybe Vertex) where
ppr (g, vf, _) = vcat (List.map (ppr . vf) (vertices g))
instance Ppr (Graph, Vertex -> ((), TGVSimple', [TGVSimple']), TGVSimple' -> Maybe Vertex) where
ppr (g, vf, _) = vcat (List.map (ppr . vf) (vertices g))
class HasTGV a where asTGV :: a -> TGV'
class HasTGVSimple a where asTGVSimple :: a -> TGVSimple'
instance HasTGV TGV where asTGV = snd
instance HasTGVSimple TGVSimple where asTGVSimple = snd
allPathNodes :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Set TGV)
allPathNodes = do
(g, vf, kf) <- askPoly >>= return . view graph
kernel <- askPoly >>= \ti -> MTL.runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti
let keep :: Set Vertex
keep = Set.fromList $ concatMap (reachable g) (mapMaybe kf kernel)
keep' :: Set TGV
keep' = Set.map (\v -> (v, view _2 (vf v))) keep
return keep'
allPathStarts :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) =>
m (Set TGVSimple)
allPathStarts = do
ts <- allPathNodes :: m (Set TGV)
Set.mapM simplify ts
view' :: MonadReaders s m => Getting b s b -> m b
view' lns = view lns <$> askPoly
allLensKeys :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Map TGVSimple (Set TGV))
allLensKeys = do
(starts :: Set TGVSimple) <- allPathStarts
foldM (\mp s -> do
ts <- lensKeys s :: m (Set TGV)
return $ Fold.foldr (Map.insertWith Set.union s . Set.singleton) mp ts
) mempty (Set.toList starts)
tgv :: MonadReaders TypeGraph m => Maybe Field -> TGVSimple -> m TGV
tgv mf s =
do let t = TGV' { _field = mf, _vsimple = asTGVSimple s}
(_g, vf, kf) <- askPoly >>= return . view graph
case kf t of
Just v -> let (_, t', _) = vf v in return (v, t')
Nothing -> error $ "tgv: " ++ show mf ++ " " ++ show s
tgvSimple :: (MonadStates ExpandMap m, DsMonad m, MonadReaders TypeInfo m, MonadReaders TypeGraph m) => Type -> m (Maybe TGVSimple)
tgvSimple t =
do (_g, _vf, kf) <- askPoly >>= return . view gsimple
s <- expandType t >>= typeVertex
return $ fmap (\k -> (k, s)) (kf s)
tgvSimple' :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) =>
Type -> m TGVSimple
tgvSimple' typ =
tgvSimple typ >>= maybe (error $ "tgvSimple' - no node for " ++ pprint1 typ) pure
lensKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) =>
TGVSimple -> m (Set TGV)
lensKeys s = do
g <- view' graph
t <- tgv Nothing s
return $ Set.fromList $ adjacent' g t
simplify :: (MonadReaders TypeGraph m, HasTGV t) => t -> m TGVSimple
simplify t = do
(_, _, kf) <- view' gsimple
let s = (view vsimple . asTGV) t
let v = (fromJust . kf) s
return (v, s)
allPathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Map TGVSimple (Set TGVSimple))
allPathKeys = do
starts <- Set.toList <$> allPathStarts
foldM (\mp s -> pathKeys s >>= return . Fold.foldr (Map.insertWith Set.union s . Set.singleton) mp) mempty starts
pathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => TGVSimple -> m (Set TGVSimple)
pathKeys s = do
gs <- view' gsimple
return $ Set.fromList $ reachable' gs s
pathKeys' :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => TGV -> m (Set TGVSimple)
pathKeys' s = do
#if 0
g <- view' graph
Set.fromList <$> Prelude.mapM simplify (reachable' g s)
#else
s' <- simplify s
gs <- view' gsimple
pure $ Set.fromList $ reachable' gs s'
#endif
reachableFrom :: forall m. (DsMonad m, MonadReaders TypeGraph m) => TGV -> m (Set TGV)
reachableFrom t = do
(g, vf, kf) <- view' graph
case kf (asTGV t) of
Nothing -> return Set.empty
Just v ->
let vs = Set.fromList (reachable (transposeG g) v) in
return $ Set.map (\v' -> let (_, t', _) = vf v' in (v', t')) vs
reachableFromSimple :: forall m. (DsMonad m, MonadReaders TypeGraph m) => TGVSimple -> m (Set TGVSimple)
reachableFromSimple s = do
(g, vf, kf) <- view' gsimple
case kf (asTGVSimple s) of
Nothing -> return Set.empty
Just v ->
let vs = Set.fromList (reachable (transposeG g) v) in
return $ Set.map (\v' -> let (_, s', _) = vf v' in (v', s')) vs
goalReachableFull :: (Functor m, DsMonad m, MonadReaders TypeGraph m, HasTGV t) => t -> t -> m Bool
goalReachableFull gkey key0 = isReachable (asTGV gkey) (asTGV key0) <$> view' graph
goalReachableSimple :: (Functor m, DsMonad m, MonadReaders TypeGraph m, HasTGVSimple s) => s -> s -> m Bool
goalReachableSimple gkey key0 = isReachable (asTGVSimple gkey) (asTGVSimple key0) <$> view' gsimple
goalReachableSimple' :: (Functor m, DsMonad m, MonadReaders TypeGraph m, HasTGV t) => t -> t -> m Bool
goalReachableSimple' gkey key0 = do
(_g, _vf, kf) <- view' gsimple
let gkey' = view vsimple (asTGV gkey)
key0' = view vsimple (asTGV key0)
goalReachableSimple (fromJust (kf gkey'), gkey') (fromJust (kf key0'), key0')
isReachable :: TypeGraphVertex key => key -> key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex) -> Bool
isReachable gkey key0 (g, _vf, kf) = path g (fromJust $ kf key0) (fromJust $ kf gkey)
typeGraphVertex :: ( MonadReaders TypeInfo m, MonadStates ExpandMap m, DsMonad m) => Type -> m TGV'
typeGraphVertex typ = do
typ' <- expandType typ
askPoly >>= \(ti :: TypeInfo) -> MTL.runReaderT (typeVertex' typ') ti
typeGraphVertexOfField :: (MonadReaders TypeInfo m, MonadStates ExpandMap m, DsMonad m) => Field -> Type -> m TGV'
typeGraphVertexOfField fld typ = do
typ' <- expandType typ
askPoly >>= \(ti :: TypeInfo) -> MTL.runReaderT (fieldVertex fld typ') ti
data VertexStatus typ
= Vertex
| Sink
| Divert typ
| Extra typ
deriving Show
instance Default (VertexStatus typ) where
def = Vertex