Graph.hs

{-|
    Search for a type signature and context through a graph.

    Return results in best-first order, taking account of which
    nodes and edges have already been paid for.
-}

module Hoogle.DataBase.TypeSearch.Graph(
    Graph, newGraph,
    graphSearch
    ) where

import Hoogle.DataBase.TypeSearch.TypeScore
import Hoogle.DataBase.TypeSearch.Binding
import Hoogle.DataBase.TypeSearch.Result
import Hoogle.DataBase.Aliases
import Hoogle.Item.All
import Hoogle.TypeSig.All
import Data.Generics.Uniplate
import Data.Binary.Defer
import Data.Binary.Defer.Index
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Heap as Heap
import General.Code
import Data.Key
import qualified Data.Binary.Defer.Graph as G
import Data.Binary.Defer.Graph hiding (Graph, Graph_)



newtype Graph = Graph (Map.Map Type [Node])

-- the Type's are stored in reverse, to make box/unbox computations quicker
data Node = Node [Type] [(Link EntryInfo,ArgPos)]


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 (linkKey a) ++ "." ++ show b | (a,b) <- xs]


instance BinaryDefer Graph where
    put (Graph a) = put1 a
    get = get1 Graph

instance BinaryDefer Node where
    put (Node a b) = put2 a b
    get = get2 Node


---------------------------------------------------------------------
-- GRAPH CONSTRUCTION


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 :: [(Link 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 :: [(Link EntryInfo, ArgPos, Type)] -> [Node]
newNode = map (uncurry Node) . sortGroupFsts . map (\(a,b,c) -> (typeUnstructure c,(a,b)))




---------------------------------------------------------------------
-- GRAPH SEARCHING

-- must search for each (node,bindings) pair, rather than just nodes

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, [(Link 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