module Hoogle.DataBase.TypeSearch.Graph(
Graph, newGraph,
graphSearch
) where
import Hoogle.DataBase.TypeSearch.Binding
import Hoogle.DataBase.TypeSearch.Result
import Hoogle.Type.All
import Data.Generics.Uniplate
import Hoogle.Store.All
import qualified Data.Map as Map
import General.Base
import General.Util
newtype Graph = Graph (Map.Map Type [Node])
data Node = Node [Type] [(Once EntryInfo,ArgPos)]
deriving Typeable
instance Show Graph where
show (Graph mp) = unlines $ concatMap f $ Map.toList mp
where f (t,ns) = show (transform g t) : map ((" "++) . show) ns
g x = if x == TVar "" then TVar "_" else x
instance Show Node where
show (Node t xs) = unwords $ map show t ++ "=" : ["?." ++ show b | (a,b) <- xs]
instance Store Graph where
put (Graph a) = put1 a
get = get1 Graph
instance Store Node where
put (Node a b) = put2 a b
get = get2 Node
typeStructure :: Type -> Type
typeStructure = transform f
where f x = if isTLit x || isTVar x then TVar "" else x
typeUnstructure :: Type -> [Type]
typeUnstructure = reverse . filter (\x -> isTLit x || isTVar x) . universe
newGraph :: [(Once EntryInfo, ArgPos, Type)] -> Graph
newGraph = Graph . Map.map newNode . foldl' f Map.empty
where f mp x = Map.insertWith (++) (typeStructure $ thd3 x) [x] mp
newNode :: [(Once EntryInfo, ArgPos, Type)] -> [Node]
newNode = map (uncurry Node) . sortGroupFsts . map (\(a,b,c) -> (typeUnstructure c,(a,b)))
graphSearch :: Graph -> Type -> [ResultArg]
graphSearch (Graph mp) t = [ResultArg e p b | (b,ep) <- sortFst xs, (e,p) <- ep]
where
xs = f newBinding s ++ f newBindingRebox (TApp (TVar "") [s]) ++
concat [f newBindingUnbox x | TApp (TVar "") [x] <- [s]]
u = typeUnstructure t
s = typeStructure t
f bind x = mapMaybe (graphCheck bind u) $ Map.findWithDefault [] x mp
graphCheck :: Binding -> [Type] -> Node -> Maybe (Binding, [(Once EntryInfo,ArgPos)])
graphCheck b xs (Node ys res) = do
b <- f b (zip xs ys)
return (b, res)
where
f b [] = Just b
f b (x:xs) = do
b <- addBinding x b
f b xs