HaddockRead.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  WinDll.Utils.HaddockRead 
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- A module to handle parsing and information querying of Haddock files
--
-----------------------------------------------------------------------------

module WinDll.Utils.HaddockRead where

import System.Environment
import System.Directory

import qualified Data.Map as M

import System.FilePath

import WinDll.Utils.Processes
import WinDll.Session
import WinDll.Utils.Feedback
import System.FilePath

import Data.List
import Data.Char

type FunctionName     = String
type Arg              = Int
type IndexedInterface = M.Map FunctionName FunctionSpec

data FunctionSpec = 
   FunctionSpec { description :: [String]
                , arguments :: [(Arg,String)]
                } deriving Show

-- | Read the function comments of the specified haddock file and create a simple datastructure to hold em.
getDocumentationInfo :: Exec IndexedInterface
getDocumentationInfo = 
 do session <- get
    let comment = pres_comment session
        build   = pipeline session
    case comment of
       False -> return M.empty
       True  -> do createProcess Nothing "haddock" createHoogle
                   specs <- liftIO $ fmap lines $ readFile ((addTrailingPathSeparator (dirPath build)) ++ "main.txt")
                   return $ parseHaddock specs M.empty
    
-- | Parse the haddock generated file and produce the map required
parseHaddock :: [String] -> IndexedInterface -> IndexedInterface
parseHaddock []    _map = _map
parseHaddock value _map 
  = let value'          = dropWhile (\x->not $ "-- |" `isPrefixOf` x) value
        (comments,rest) = span (\x->"-- " `isPrefixOf` x) value'
        (func:rest')    = rest
        isFunction x    = case x of
                            ':' -> True
                            _   -> False
        name            = takeWhile (\x-> not $ (isFunction x) || isSpace x) func
        isPart x        = case x of
                            '-' -> True
                            ' ' -> True
                            '|' -> True
                            _   -> False
        comment         = concatMap (reverse . dropWhile isSpace . reverse . dropWhile isPart) comments
        cmt'            = cleanupHaddock comment []
        specs           = FunctionSpec (([]:cmt')++[[]]) []
    in if null rest || null name then _map else parseHaddock rest' (M.insert name specs _map)
 
-- | Convert a long string into a haddock representation by splitting "." as newlines.
cleanupHaddock :: String -> String -> [String]
cleanupHaddock []              r = [reverse r]
cleanupHaddock (' ':'.':' ':x) r = reverse r : cleanupHaddock x []
cleanupHaddock ('<':'a':'>':x) r = cleanupHaddock x ('"':r)
cleanupHaddock ('<':'/':'a':'>':x) r = cleanupHaddock x ('"':r)
cleanupHaddock (c:x)           r = cleanupHaddock x (c:r)
 
-- | Generate hoogle documentation
createHoogle :: Exec (String, [String])
createHoogle = 
 do session <- get
    let dir  = addTrailingPathSeparator (baseDir session)
        deps  = (dependencies.workingset) session
        paths = (absPath session : map guessPath (drop 1 deps))
    return ("main.txt"
           , -- ["--optghc=\"-i" ++ if ' ' `elem` dir then show dir else dir ++ "\"" 
           ("--hoogle" : map (dir++) paths)
           )