module Main(main) where

import Char
import IO
import List
import Maybe
import Monad
import System
import GetOpt

import Parser
import HDocDefs
import CombHsHDoc
import DocGen
import ThePrelude (preludeAndStdLibs)
import qualified Version

import HDoclet
import Unicode (allSymbols)

import HsSyn


run :: SysConf -> [Flag] -> [Input] -> IO ()
run sysconf flags inputs =
    do loadres <- loadFiles hdSet searchPath filesWithPkg
       case loadres of
		    Right msg   -> putStrLn msg
		    Left  hdInp -> makeDocs hdSet hdInp
    where
    hdSet = HDS
	    { hdsExportsOnly    = any (==ExportsOnly) flags,
	      hdsLineNumbers    = any (==LineNumbers) flags,
	      hdsDestinationDir = head ([d | OutputDir d <- flags] ++ ["."])
	                          ++ [dirSeparator sysconf],
	      hdsStyleSheetFile = listToMaybe [f | StyleSheetFile f <- flags],
	      hdsDirSeparator   = [dirSeparator sysconf],
	      hdsDocumentTitle  = head ([t | DocTitle t <- flags] ++
					[defaultTitle])
	    }
    defaultTitle = "HDoc autogenerated documentation"

    searchPath = ('.':dirSeparator sysconf:"") :
		 [path ++ [dirSeparator sysconf] | IncludeDir path <- flags]

    filesWithPkg :: [(FilePath, Maybe String)]
    filesWithPkg = fwpRec Nothing inputs
	where
	fwpRec _ [] = []
	fwpRec _   (PkgName  pn : inps) = fwpRec (Just pn) inps
	fwpRec pkg (InputMod f  : inps) = (f, pkg) : fwpRec pkg inps


makeDocs :: HDocSettings -> HDocInput -> IO ()
makeDocs hdSet hdInp = htmlDoclet docletInput
    where
    docletInput = HDocletInput { allDocuPackages = [],
				 allDocuModules = dms,
				 allDocuFunctions = allFs,
				 allDocuTypesynonyms = allTs,
				 allDocuDatatypes = allDs,
				 allDocuClasses   = allCs,
				 allDocuInstances = allIs,
				 hdocSettings = hdSet
			       }

    dms   = map mkDM (liftSort moduleName (visibleModules hdInp))
    allFs = liftSort thename $ nub $
	    concat [documentedFunctions dm | dm <- dms]
    allTs = liftSort (thename . fst) $ nub $
	    concat [documentedTypesynonyms dm | dm <- dms]
    allDs = liftSort (thename . fst) $ nub $
	    concat [documentedDatatypes dm | dm <- dms]
    allCs = liftSort (thename . fst) $ nub $
	    concat [documentedClasses dm | dm <- dms]
    allIs = liftSort thename $ nub $
	    concat [documentedInstances dm | dm <- dms]

    mkDM :: ModuleDoc -> DocumentedModule
    mkDM md = DocumentedModule { documentedModule    = md,
				 documentedFunctions = fds md,
				 documentedTypesynonyms = tds md,
				 documentedDatatypes = dds md,
				 documentedClasses   = cds md,
				 documentedInstances = ids md,
				 alsoFunctions    = alsoFs md,
				 alsoTypesynonyms = alsoTs md,
				 alsoDatatypes    = alsoDs md,
				 alsoClasses      = alsoCs md,
				 alsoInstances    = alsoIs md
			       }
    
    fds md = liftSort thename $ 
	     if expOnly
	       then [f | ExportFunction f <- exports md, appearsInOutput f]
	       else functions md
    tds md = liftSort (thename . fst) $
	     if expOnly
	       then [(t,c) | ExportType t c <- exports md, appearsInOutput t]
	       else [(t,Just (constructorT t)) | t <- typesynonyms md]
    dds md = liftSort (thename . fst) $
	     if expOnly
	       then [(d, cons) | ExportData d cons <- exports md,
		                 appearsInOutput d]
	       else [(d, constructors d) | d <- datatypes md]
    cds md = liftSort (thename . fst) $
	     if expOnly
	       then [(c, knownInstances hdInp c) |
		     ExportClass c _ <- exports md, appearsInOutput c]
	       else [(c, knownInstances hdInp c) | c <- classes md]
    ids md = liftSort thename $
	     if expOnly
	       then [i | ExportInstance i <- exports md, appearsInOutput i]
	       else instances md

    -- allFs is sorted and contains no duplicates, so
    -- (due to the definition of intersect), the same is true for alsoFs
    --
    -- alsoFs md  and  fds md  should be disjoint for every module md.
    alsoFs md = allFs `intersect`
		if expOnly
		   then [f | ExportFunction f <- exports md,
			     appearsInOutput f == False,
			     hiddenM (themodule f) == False]
		   else [f | ExportFunction f <- exports md,
			     f `notElem` functions md,
			     hiddenM (themodule f) == False]
    alsoTs md = allTs `intersect`
		if expOnly
		   then [(t,c) | ExportType t c <- exports md,
			         appearsInOutput t == False,
			         hiddenM (themodule t) == False]
		   else [(t,c) | ExportType t c <- exports md,
			         t `notElem` typesynonyms md,
			         hiddenM (themodule t) == False]
    alsoDs md = allDs `intersect`
		if expOnly
		   then [(d, cons) | ExportData d cons <- exports md,
		                     appearsInOutput d == False,
			             hiddenM (themodule d) == False]
		   else [(d, cons) | ExportData d cons <- exports md,
			             d `notElem` datatypes md,
			             hiddenM (themodule d) == False]
    alsoCs md = allCs `intersect`
		if expOnly
		   then [(c, knownInstances hdInp c) |
			 ExportClass c _ <- exports md,
			 appearsInOutput c == False,
			 hiddenM (themodule c) == False]
		   else [(c, knownInstances hdInp c) |
			 ExportClass c _ <- exports md, c `notElem` classes md,
			 hiddenM (themodule c) == False]
    alsoIs md = allIs `intersect`
		if expOnly
		   then [i | ExportInstance i <- exports md,
			     appearsInOutput i == False,
			     hiddenM (themodule i) == False]
		   else [i | ExportInstance i <- exports md,
			     i `notElem` instances md,
			     hiddenM (themodule i) == False]

    expOnly = hdsExportsOnly hdSet

    liftSort :: Ord b => (a -> b) -> [a] -> [a]
    liftSort f = sortBy g
	where
	g x y = compare (f x) (f y)


loadFiles :: HDocSettings -> [FilePath] -> [(FilePath, Maybe String)] ->
	     IO (Either HDocInput String)
loadFiles hdSet searchPath filesWithPkg =
    do  inputs <- sequence $ map (loadModule searchPath) filesWithPkg
	let (hsmRes, hdocRes) = unzip [hsAndhdoc | Right hsAndhdoc <- inputs]
	    inputErrors = [err | Left err <- inputs]

            parsedPrel  = map parseHsmPrel preludeAndStdLibs
	    prelErrors  = [err | Left err <- parsedPrel]
	    parseResP
		| null prelErrors = [m   | Right  m   <- parsedPrel]
		| otherwise    = error ("parse error in Prelude!\n" ++
					concat [i++"\n\n" | i <- prelErrors])
	case inputErrors of
	    [] -> do impHP <- resolveImports searchPath (parseResP ++ hsmRes)
		     let hdInp   = HDI res res resP
			 fullInp = HDI (res++resI++resP) res resP
			 resP = [combineHsHDoc hdSet (HDI resP [] resP) p [] |
				 p <- parseResP]
			 resI = [let x = combineHsHDoc hdSet fullInp p (sh x)
				 in x | (p,sh) <- impHP]
			 res  = [let x = combineHsHDoc hdSet fullInp p (sh x)
				 in x | (p,sh) <- zip hsmRes hdocRes]
		     return (Left hdInp)
	    errs -> return (Right $ concat [e ++ "\n\n" | e <- errs])
    where
    ferr :: [(String, String)] -> String
    ferr xs = concat [ferr' x ++ "\n\n" | x <- xs]
    ferr' (msg, file) = "In file " ++ file ++ "\n" ++
			unlines ["  " ++ l | l <- lines msg]

    parseHsmPrel :: String -> Either String HsMod
    parseHsmPrel m =
	case parseHs m of
	    Left err       -> Left err
	    Right hsmodule -> Right $ HsMod { hsmHsModule = hsmodule,
					      hsmPackage  = NoPackage }


resolveImports :: [FilePath] -> [HsMod] -> IO [(HsMod,ParsedHDoc)]
resolveImports searchPath modules = resolve modules []
    where
    resolve mods unavails =
	do res   <- sequence (map (loadModuleAlso searchPath) imps)
	   let newMs          = [p | Just p <- res]
	       (newHs, newPs) = unzip newMs
	       notFounds      = [m | (m, Nothing) <- zip imps res]
	   if (null newMs)
	      then return []
	      else do newnewMs <- resolve (mods ++ newHs) (notFounds++unavails)
		      return (newMs ++ newnewMs)
	where
	loaded = [m | HsModule _ (Module m) _ _ _ <- map hsmHsModule mods]
	imps :: [String]
	imps = nub [m | HsModule _ _ _ is _ <- map hsmHsModule mods,
	                HsImportDecl _ (Module m) _ _ _ <- is,
                        m `notElem` loaded, m `notElem` unavails]

    
safeZipR :: [a] -> [b] -> [(a,b)]
safeZipR xs ys = zipWith (\x i -> (x,ys!!i)) xs [0..]

loadModule :: [FilePath] -> (FilePath, Maybe String) ->
	      IO (Either String (HsMod, ParsedHDoc))
loadModule searchPath (filename, mbPackage) = 
    do loadres <- loadModuleFromFiles filesToTry modName
       case loadres of
           Left NotFound          ->
	       return $ Left $
	       case modName of
		    Nothing -> "file not found: " ++ filename
		    Just m  -> "could not find module \"" ++ m ++
			       "\" on search path"
	   Left (NoPreprocessor f)  ->
	       return $ Left ("don't know how to handle " ++ f ++
			      " (unknown extension)")
	   Left (WrongModule f mod) -> return $ Left $ ferr f msg
	       where
	       msg = case modName of
		     Nothing -> "internal error in loading code"
		     Just m  -> "source declares module \"" ++ mod ++
				"\",\nbut HDoc expected module \"" ++ m ++ "\""
	   Left (InputError  f msg) -> return $ Left $ ferr f msg
	   Left (HsError     f msg) -> return $ Left $ ferr f msg
	   Left (HDocError   f msg) -> return $ Left $ ferr f msg
	   Right (file, msg, hsmodule, phd) ->
	       do let hsm = HsMod { hsmHsModule = hsmodule,
				    hsmPackage = package }
	          putStrLn ("reading " ++ file ++ "  " ++ msg)
		  return (Right (hsm, phd))
    where
    package = case mbPackage of
		Nothing -> NoPackage
		Just p  -> PackageName p
    ferr file msg = "In file " ++ file ++ ":\n" ++
		    unlines ["  " ++ l | l <- lines msg]
    (filesToTry, modName)
	| any (`isSuffixOf` filename) sourceSuffixes = ([filename], Nothing)
	| otherwise                                  =
            ([path ++ makeFileNameFromModule filename ++
              suffix | path <- searchPath, suffix <- sourceSuffixes],
	     Just filename)

makeFileNameFromModule :: String -> String
makeFileNameFromModule = map (\x -> if x == '.' then '/' else x)

loadModuleAlso :: [FilePath] -> String -> IO (Maybe (HsMod, ParsedHDoc))
loadModuleAlso searchPath modName =
    do loadres <- loadModuleFromFiles filesToTry (Just modName)
       case loadres of
           Left NotFound        ->
	       putStrLn ("info: module " ++ modName ++ " not found") >>
	       return Nothing
	   Left (NoPreprocessor f)  ->   -- should *never* happen
	       putStrLn ("oops: no preprocessor for " ++ f ++" ?!") >>
	       return Nothing
	   Left (WrongModule f m) ->
	       putStrLn ("warning: " ++ f ++ " declares " ++
			 "module \"" ++ m ++ "\" -- ignored") >>
	       return Nothing
	   Left (InputError  f err) -> errInMod f err
	   Left (HsError     f err) -> errInMod f err
	   Left (HDocError   f err) -> errInMod f err
	   Right (f, msg, hsmodule, phd)  -> 
	       do let hsm = HsMod { hsmHsModule = hsmodule,
				 hsmPackage = UnknownPackage }
	          putStrLn ("info: also loaded " ++ f ++ "  " ++ msg)
	          return (Just (hsm, phd))
    where
    filesToTry = [path ++ makeFileNameFromModule modName ++
                  suffix | path <- searchPath, suffix <- sourceSuffixes]
    errInMod f err = putStrLn ("info: module \"" ++ modName ++
			       "\" (" ++ f ++ ") not loaded:\n" ++ err2) >>
		     return Nothing
	where
	err2 = unlines ["  " ++ l | l <- lines err]

						   
data LoadError = NotFound
	       | NoPreprocessor FilePath
	       | WrongModule FilePath String
	       | InputError  FilePath String
	       | HsError     FilePath String
	       | HDocError   FilePath String

loadModuleFromFiles :: [FilePath] -> Maybe String ->
		       IO (Either LoadError (FilePath, String,
					     HsModule, ParsedHDoc))
loadModuleFromFiles filenames modName = load filenames
    where
    load []     = return $ Left NotFound
    load (f:fs) =
	loadAfile f >>= \res ->
	case res of
	Right (cont,msg) ->
	    case (parseHs cont, parseHDoc cont) of
	    (Right (m@(HsModule _ (Module m') _ _ _)), Right h) -> 
		  if modName == Nothing || modName == Just m'
		    then return $ Right (f, msg, m, h)
		    else return (Left $ WrongModule f m')
	    (Left err, _) -> return (Left $ HsError f err)
	    (_, Left err) -> return (Left $ HDocError f err)
	Left np@(NoPreprocessor _) -> return $ Left np
	Left _                     -> load fs


loadAfile :: String -> IO (Either LoadError (String,String))
loadAfile file =
    case preProc of
    Nothing -> return $ Left (NoPreprocessor file)
    Just (msg, action) ->
	do res <- try (readFile file)
	   case res of
	     Left _     -> return $ Left NotFound
	     Right cont -> return $ Right (action cont,msg)
    where
    preProc = listToMaybe [(msg, act) | (suf, msg, act) <- preProcessors,
			                suf `isSuffixOf` (map toLower file)]

sourceSuffixes :: [String]
sourceSuffixes = [".gc", ".lhs", ".hs"]

-- preprocessors for different file formats
preProcessors :: [(String, String, String -> String)]
preProcessors = [(".hs",  "", id),
		 (".gc",  "(removing GreenCard directives)", deGreenCard),
		 (".lhs", "", deLHS)]

-- Literate Haskell Script preprocessor
deLHS :: String -> String
deLHS input = if any ("\\begin{code}" `isPrefixOf`) (lines input)
	      then deLatexLHS input
	      else deGtLHS input

deGtLHS :: String -> String
deGtLHS = unlines . map removeGt . lines
	  where
	  removeGt ('>':' ':xs) = xs
	  removeGt _            = ""

deLatexLHS :: String -> String
deLatexLHS input = unlines $ l False (lines input)
    where
    l _ []      = []
    l False (x:xs)
	| "\\begin{code}" `isPrefixOf` x  =  "" : l True  xs
	| otherwise                       =  "" : l False xs
    l True (x:xs)
	| "\\end{code}"   `isPrefixOf` x  =  "" : l False xs
	| otherwise                       =  x  : l True  xs

-- Green Card preprocessor:
-- remove lines starting with %, but retain signatures after  %fun
-- BUG:
--   {-
--   %fun f :: Int -> Int
--   -}
-- *does* define f for HDoc :-(
--
deGreenCard :: String -> String
deGreenCard = unlines . removeGC . lines
    where
    removeGC []     = []
    removeGC (l:ls) =
	case l of
	       "%fun" -> "" : (sigRest ++ removeGC nonSigRest)
	       '%':'f':'u':'n':x:xs ->
		   if isSpace x
		      then xs : (sigRest ++ removeGC nonSigRest)
		      else "" : removeGC ls
	       '%':xs -> "" : removeGC ls
	       xs     -> xs : removeGC ls
	where
	sigRest = map tail sigRest'
	(sigRest', nonSigRest) = span isSigCont ls
	isSigCont "%"        = True
	isSigCont ('%':x:xs) = isSpace x
	isSigCont _          = False


data CmdLineArg = ClaFlag  Flag
		| ClaInput Input

data Flag = OutputDir FilePath
	  | ExportsOnly
	  | LineNumbers
	  | IncludeDir FilePath
	  | HDocVersion
	  | DocTitle String
	  | StyleSheetFile FilePath
	  | ShowHelp
	  | ShowSymbols
	    deriving Eq

data Input = InputMod FilePath
	   | PkgName  String


options =
    [ Option ['d'] ["destdir"]  (ReqArg (ClaFlag . OutputDir)  "DIR")
        "Send output to directory DIR",
      Option ['e'] ["exports"]  (NoArg  (ClaFlag ExportsOnly))
        "Document exported objects only",
      Option []    ["line-numbers"] (NoArg (ClaFlag LineNumbers))
        "Output line numbers",
      Option ['t'] ["title"]    (ReqArg (ClaFlag . DocTitle)   "TITLE")
        "Set the document title",
      Option ['i', 'I']  []     (ReqArg (ClaFlag . IncludeDir) "PATH")
        "Search PATH for modules",
--
-- packages not supported, yet!
--      Option [] ["package-name"] (ReqArg (ClaInput . PkgName)  "PKG-NAME")
--        "Set package name for following modules",
      Option []    ["stylesheet"]  (ReqArg (ClaFlag . StyleSheetFile) "FILE")
        "Set the stylesheet to use",
      Option []    ["show-symbols"] (NoArg (ClaFlag ShowSymbols))
        "Show all supported named symbols",
      Option ['V'] ["version"]  (NoArg  (ClaFlag HDocVersion))
        "Print HDoc's version number",
      Option ['h'] ["help"]     (NoArg  (ClaFlag ShowHelp))
        "Print this (short) help"
    ]

data SysConf = SysConf { dirSeparator :: Char }

-- "/" works as path separator under Windows with Hugs, GHC, and nhc98,
-- so there's no need to use "\\" on Windows!
getSysConf :: IO SysConf
getSysConf = return SysConf { dirSeparator = '/' }
{-
    do ge <- try (getEnv "WINDIR")
       case ge of
	       Right sysdir -> 
		   if length sysdir >= 3 && (sysdir!!2) == '\\'
		   then return SysConf { dirSeparator='\\' }     -- windows
		   else return SysConf { dirSeparator='/'  }     -- not windows
	       Left _ -> return SysConf { dirSeparator='/'  }    -- not windows
-}

handleSpecialOptions :: [Flag] -> IO Bool
handleSpecialOptions flags
    | HDocVersion `elem` flags  =  putStrLn Version.version >> return True
    | ShowHelp    `elem` flags  =  header >>= \h ->
				   putStrLn (usageInfo h options) >>
				   return True
    | ShowSymbols `elem` flags  =  putStrLn symbols >> return True
    | otherwise  =  return False
    where
    symbols = "Available Symbols:\n" ++
	      unlines ["  " ++ syms | syms <- mk4syms allSymbols]
    mk4syms :: [String] -> [String]
    mk4syms [] = []
    mk4syms ss = concat (map prep $ take 4 ss) : mk4syms (drop 4 ss)
    prep xs = take 14 (xs ++ repeat ' ')

header :: IO String
header = getProgName >>= \hdoc ->
	 return ("Usage: " ++ hdoc ++ " [OPTION...] file/module...")

main :: IO ()
main =
    do sysconf <- getSysConf
       args <- getArgs
       case (getOpt (ReturnInOrder (ClaInput . InputMod)) options args) of
          ([],    [],   []) -> handleSpecialOptions [ShowHelp] >> return ()
--          (flags, [],   []) -> handleSpecialOptions flags      >> return ()
          (flags', [], []) ->
	      do let (flags, inputs) = splitFlags flags'
		 handled <- handleSpecialOptions flags
		 if handled
		    then return ()
		    else run sysconf flags inputs
          (_, _, errs) -> header >>= \h ->
			  putStrLn (concat errs ++ usageInfo h options)
    where
    splitFlags :: [CmdLineArg] -> ([Flag], [Input])
    splitFlags = foldr sel ([],[])
	where
	sel (ClaInput x) (fs, is) = (fs, x:is)
	sel (ClaFlag  x) (fs, is) = (x:fs, is)