Result.hs

{-
    This file is part of Hoogle, (c) Neil Mitchell 2004-2005
    http://www.cs.york.ac.uk/~ndm/hoogle/
    
    This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike License.
    To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/2.0/
    or send a letter to Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA.
-}

module Hoogle.Result where

import Hoogle.TypeSig
import Data.List


type Score = Int

data Result = Result {
                  resultModule :: TagStr,
                  resultName :: TagStr,
                  resultType :: TagStr,
                  resultMode :: String,
                  resultInfo :: [Reason],
                  resultScore :: Score,
                  resultPriority :: Int
                  }
                  deriving Show


instance Eq Result where
    a == b = resultScore a == resultScore b && resultPriority a == resultPriority b

instance Ord Result where
    compare a b = compare (resultScore b, resultPriority b) (resultScore a, resultPriority a)


-- some typical tags
--  a, hyperlink
--  b, bold
--  u, underline
--  1-6, color 1-6


data TagStr = Str String
            | Tag String TagStr
            | Tags [TagStr]
              deriving Show


data Reason = ReasonText TextAmount
            | ReasonLeft MatchAmount
            | ReasonRight MatchAmount
            
            


instance Show Reason where
    show (ReasonText x) = show x
    show (ReasonLeft x) = 'L' : show x
    show (ReasonRight x) = 'R' : show x
    
    showList [ReasonText x] = showString $ show x
    showList xs = showString $ f 'L' left ++ g left right ++ f 'R' right
        where
            (left, right) = partition isLeft xs
            
            f pre [] = ""
            f pre xs = pre : concatMap (tail . show) xs
            
            g (_:_) (_:_) = "."
            g _ _ = ""
            
            isLeft (ReasonLeft _) = True
            isLeft _ = False


data TextAmount = TextFullCase
                | TextFull
                | TextPrefixCase
                | TextPrefix
                | TextSuffix
                | TextSome
                  deriving Show

data MatchAmount = DataTooFree
                 | DataTooSpecific
                 | FreeDifferent
                 | ClassMinor
                 | ClassMajor
                 | ArgExtra
                 deriving (Bounded, Eq, Enum)

instance Show MatchAmount where
    show DataTooFree = "?"
    show DataTooSpecific = "!"
    show FreeDifferent = "*"
    show ArgExtra = "#"
    show ClassMinor = "c"
    show ClassMajor = "C"


showText :: TagStr -> String
showText (Str x) = x
showText (Tag n x) = showText x
showText (Tags xs) = concatMap showText xs




class Scoreable a where
    score :: a -> Score

instance Scoreable a => Scoreable [a] where
    score xs = sum (map score xs)

instance Scoreable Reason where
    score (ReasonText  x) = score x
    score x = 0 - scoreGenerated x
    --score (ReasonLeft  x) = score x
    --score (ReasonRight x) = score x
    
instance Scoreable TextAmount where
    score TextFullCase = 6
    score TextFull = 5
    score TextPrefixCase = 4
    score TextPrefix = 3
    score TextSuffix = 2
    score TextSome = 1

instance Scoreable MatchAmount where
    score FreeDifferent = -1
    score ArgExtra = -2
    score ClassMinor = -1
    score ClassMajor = -10
    score _ = -5


-- this function is based on data generated by Score
scoreGenerated :: Reason -> Score
scoreGenerated (ReasonLeft  DataTooFree    ) = 1
scoreGenerated (ReasonLeft  DataTooSpecific) = 5
scoreGenerated (ReasonLeft  FreeDifferent  ) = 9
scoreGenerated (ReasonLeft  ClassMinor     ) = 2
scoreGenerated (ReasonLeft  ClassMajor     ) = 9
scoreGenerated (ReasonLeft  ArgExtra       ) = 2
scoreGenerated (ReasonRight DataTooFree    ) = 6
scoreGenerated (ReasonRight DataTooSpecific) = 16
scoreGenerated (ReasonRight FreeDifferent  ) = 1
scoreGenerated (ReasonRight ClassMinor     ) = 3
scoreGenerated (ReasonRight ClassMajor     ) = 1
scoreGenerated (ReasonRight ArgExtra       ) = 16


showTypeTags :: ConType -> [Int] -> TagStr
showTypeTags (con, typ) tags = Tags $ Str (showCon con) : f typ
    where
        f (TList (TLit "->":xs)) = intersperse (Str " -> ") $ zipWith g tags xs
        f x = [Str $ showType typ]
        
        g 0 typ = Str $ showTypePrec 1 typ
        g n typ = Tag (show n) (g 0 typ)