Item.hs

module Hoogle.Item.Item where

import General.Code
import Data.Binary.Defer
import Data.Binary.Defer.Index
import Hoogle.Item.Haddock
import Hoogle.TextBase.All
import Hoogle.TypeSig.All
import Data.Range
import Data.TagStr
import Data.Typeable


data Package = Package
    {packageName :: String
    ,packageVersion :: String
    ,haddockURL :: String
    ,hackageURL :: String
    }

typename_Package = mkTyCon "Hoogle.DataBase.Item.Package"
instance Typeable Package where typeOf _ = mkTyConApp typename_Package []


data Module = Module
    {moduleName :: [String]
    }

typename_Module = mkTyCon "Hoogle.DataBase.Item.Module"
instance Typeable Module where typeOf _ = mkTyConApp typename_Module []


-- TODO: Is entryName every used? Can it make use of the invariant?
--       Perhaps just store the entryText, then regenerate entryName at load time

-- invariant: entryName == head [i | Focus i <- entryText]
data Entry = Entry
    {entryModule :: Maybe (Link Module)
    ,entryPackage :: Link Package
    ,entryName :: String
    ,entryText :: [EntryText]
    ,entryType :: EntryType
    ,entryDocs :: Haddock
    ,entryTypesig :: Maybe (Defer TypeSig)
    }


typename_Entry = mkTyCon "Hoogle.DataBase.Item.Entry"
instance Typeable Entry where typeOf _ = mkTyConApp typename_Entry []


data EntryText = Keyword String
               | Text String
               | Focus String -- the bit text search starts from
               | ArgPos Int String
               | ArgRes String
                 deriving Show

data EntryView = FocusOn Range -- characters in the range should be focused
               | ArgPosNum Int Int -- argument a b, a is remapped to b
                 deriving Show

data EntryType = EntryModule
               | EntryPackage
               | EntryKeyword
               | EntryOther
                 deriving (Eq,Enum,Show)


-- TODO: EntryScore is over-prescriptive, and not overly useful
--       Have name and type scores to it themselves, using name only
--       to break ties when merging
-- the number of elements in the module name
-- the name of the entry, in lower case
-- the name of the entry
-- the module
data EntryScore = EntryScore Int String String [String]
                  deriving (Eq,Ord)


entryScore :: Entry -> EntryScore
entryScore e = EntryScore
    (if entryType e == EntryOther then length m else 0)
    (map toLower $ entryName e) (entryName e) m
    where m = maybe [] (moduleName . fromLink) $ entryModule e


renderEntryText :: [EntryView] -> [EntryText] -> TagStr
renderEntryText view = Tags . map f
    where
        args = not $ null [() | ArgPosNum _ _ <- view]

        f (Keyword x) = TagUnderline $ Str x
        f (Text x) = Str x
        f (ArgPos i s) = (if null res then id else TagColor (head res)) $ Str s
            where res = [k+1 | ArgPosNum k j <- view, j == i]
        f (ArgRes s) = (if args then TagColor 0 else id) $ Str s
        f (Focus x) = TagHyperlink "" $ renderFocus [i | FocusOn i <- view] x


renderFocus :: [Range] -> String -> TagStr
renderFocus rs = Tags . f (mergeRanges rs) 0
    where
        str s = [Str s | s /= ""]

        f [] i s = str s
        f (r:rs) i s =
                str s1 ++ [TagBold $ Str s3] ++ f rs (rangeEnd r + 1) s4
            where
                (s1,s2) = splitAt (rangeStart r - i) s
                (s3,s4) = splitAt (rangeCount r) s2


renderTextItem :: TextItem -> [EntryText]
renderTextItem x = case x of
    ItemClass i -> [Keyword "class", Text " "] ++ typeHead i
    ItemFunc name typ -> operator name ++ [Text " :: "] ++ renderTypeSig typ
    ItemAlias a b -> [Keyword "type", Text " "] ++ typeHead a ++ [Text $ " = " ++ show b]
    ItemData d t -> [Keyword (show d), Text " "] ++ typeHead t
    where
        typeHead (TypeSig con sig) = [Text $ showConstraint con, Focus a, Text b]
            where (a,b) = break (== ' ') $ show sig

        operator xs@(x:_) | not $ isAlpha x || x `elem` "#_'" = [Text "(",Focus xs,Text ")"]
        operator xs = [Focus xs]


renderTypeSig :: TypeSig -> [EntryText]
renderTypeSig (TypeSig con sig) = Text (showConstraint con) :
    intersperse (Text " -> ") (zipWith ArgPos [0..] a ++ [ArgRes b])
    where (a,b) = initLast $ map showFun $ fromTFun sig


showModule = concat . intersperse "."

instance Show Package where
    show (Package a b c d) = unwords $ filter (/= "") [a,b,c,d]

instance Show Module where
    show (Module a) = showModule a

instance Show Entry where
    show e = unwords [concatMap f $ entryText e, m]
        where
            m = case entryModule e of
                    Nothing -> ""
                    Just y -> "{#" ++ show (linkKey y) ++ "}"

            f (Keyword x) = x
            f (Text x) = x
            f (Focus x) = x
            f (ArgPos _ x) = x
            f (ArgRes x) = x


instance BinaryDefer Package where
    put (Package a b c d) = put4 a b c d
    get = get4 Package

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

instance BinaryDefer Entry where
    put (Entry a b c d e f g) = put7 a b c d e f g
    get = get7 Entry

instance BinaryDefer EntryText where
    put (Keyword a)  = putByte 0 >> put1 a
    put (Text a)     = putByte 1 >> put1 a
    put (Focus a)    = putByte 2 >> put1 a
    put (ArgPos a b) = putByte 3 >> put2 a b
    put (ArgRes a)   = putByte 4 >> put1 a

    get = do i <- getByte
             case i of
                0 -> get1 Keyword
                1 -> get1 Text
                2 -> get1 Focus
                3 -> get2 ArgPos
                4 -> get1 ArgRes

instance BinaryDefer EntryType where
    put = putEnumByte
    get = getEnumByte