module Hoogle.DataBase.TypeSearch.Binding(
Binding, newBinding, newBindingUnbox, newBindingRebox,
addBinding, costBinding, costsBinding, mergeBindings, bindings
) where
import Hoogle.Type.All
import Hoogle.Score.All
import Data.Function
import General.Base
import qualified Data.Map as Map
import qualified Data.Set as Set
type Var = String
type Lit = String
type Bind = Map.Map Var (Maybe Lit, Set.Set Var)
data Binding = Binding !Int [Box] Bind Bind
data Box = Unbox | Rebox
deriving (Show,Eq)
instance Show Binding where
show b@(Binding _ box _ _) = unwords $ map (map toLower . show) box ++ map f (bindings b)
where f (a,b) = show a ++ "=" ++ show b
instance Eq Binding where
(==) = (==) `on` costBinding
instance Ord Binding where
compare = comparing costBinding
costBinding :: Binding -> Int
costBinding (Binding x _ _ _) = x
newBinding, newBindingUnbox, newBindingRebox :: Binding
newBinding = Binding 0 [] Map.empty Map.empty
newBindingUnbox = Binding (cost CostUnbox) [Unbox] Map.empty Map.empty
newBindingRebox = Binding (cost CostRebox) [Rebox] Map.empty Map.empty
costIf b v = if b then cost v else 0
addBinding :: (Type, Type) -> Binding -> Maybe Binding
addBinding (TVar a, TVar b) (Binding c box x y) = Just $ Binding c2 box x2 y2
where (x2,cx) = addVar a b x
(y2,cy) = addVar b a y
c2 = c + costIf cx CostDupVarQuery + costIf cy CostDupVarResult
addBinding (TVar a, TLit b) (Binding c box x y) = do
(x2,cx) <- addLit a b x
return $ Binding (c + costIf cx CostRestrict) box x2 y
addBinding (TLit a, TVar b) (Binding c box x y) = do
(y2,cy) <- addLit b a y
return $ Binding (c + costIf cy CostUnrestrict) box x y2
addBinding (TLit a, TLit b) bind = if a == b then Just bind else Nothing
addVar :: Var -> Var -> Bind -> (Bind, Bool)
addVar a b mp = case Map.lookup a mp of
Nothing -> (Map.insert a (Nothing, Set.singleton b) mp, False)
Just (l, vs) | b `Set.member` vs -> (mp, False)
| otherwise -> (Map.insert a (l, Set.insert b vs) mp, True)
addLit :: Var -> Lit -> Bind -> Maybe (Bind, Bool)
addLit a b mp | l == Just b = Just (mp, False)
| isJust l = Nothing
| otherwise = Just (Map.insert a (Just b, vs) mp, True)
where (l, vs) = Map.findWithDefault (Nothing, Set.empty) a mp
mergeBindings :: [Binding] -> Maybe Binding
mergeBindings bs = do
let (box,ls,rs) = unzip3 [(b,l,r) | Binding _ b l r <- bs]
(bl,br) = (Map.unionsWith f ls, Map.unionsWith f rs)
res i = Binding i (concat box) bl br
s <- costsBindingLocal (res 0)
return $ res (sum $ map cost s)
where
f (l1,vs1) (l2,vs2)
| l1 /= l2 && isJust l1 && isJust l2 = (Just "", vs1)
| otherwise = (l1 `mplus` l2, Set.union vs1 vs2)
costsBindingLocal :: Binding -> Maybe [TypeCost]
costsBindingLocal (Binding _ box l r) = do
let cb = [if b == Unbox then CostUnbox else CostRebox | b <- box]
cl <- f CostDupVarQuery CostRestrict l
cr <- f CostDupVarResult CostUnrestrict r
return $ cb++cl++cr
where
f var restrict = concatMapM g . Map.elems
where
g (Just "", _) = Nothing
g (l, vs) = Just $ [restrict|isJust l] ++ replicate (max 0 $ Set.size vs 1) var
costsBinding :: Binding -> [TypeCost]
costsBinding = fromJust . costsBindingLocal
bindings :: Binding -> [(Type, Type)]
bindings (Binding _ _ a b) =
[(TVar v, t) | (v,(l,vs)) <- Map.toList a, t <- [TLit l | Just l <- [l]] ++ map TVar (Set.toList vs)] ++
[(TLit l, TVar v) | (v,(Just l,_)) <- Map.toList b]