{-# LANGUAGE BangPatterns #-}

module Main where

import           Data.Char
import           Data.List                             (intercalate, nub, sort,
                                                        sortBy)
import           Data.Ord                              (comparing)
import           Data.Maybe
import           Data.MemoTrie
import           Data.Traversable                      (traverse)
import           Distribution.ModuleName               (components)
import qualified Distribution.Package                  as P
import qualified Distribution.PackageDescription       as PD
import qualified Distribution.PackageDescription.Parse as PDP
import           Distribution.Verbosity                (normal)
import           Language.Haskell.Interpreter          (ModuleName, ModuleElem(..))
import qualified Language.Haskell.Interpreter          as Hint
import           System.Environment
import           System.IO
import           System.IO.Unsafe
import           System.Process
import           Text.Regex

type Identifier = String

------------------------------------------------------------------------------------------

main :: IO ()
main = do
    args <- getArgs
    runStd args

runStd :: [FilePath] -> IO ()
runStd = runFilter stdin stdout

runFilter :: Handle -> Handle -> [FilePath] -> IO ()
runFilter inf outf args = hGetContents inf >>= run args >>= hPutStr outf

------------------------------------------------------------------------------------------

-- |
-- Given a list of cabal files, process input by replacing all text on the form
-- @[foo] with [`foo`][foo], replacing @@@hslinks@@@ with an index on the form:
--
-- [foo]:         prefix/Module-With-Foo.html#v:foo
-- [Foo]:         prefix/Module-With-Foo.html#t:Foo
--
-- etc.
--
run :: [FilePath] -> String -> IO String
run args input = do
    -- !packageNames <- packageNameInCabals args
    -- !modNames     <- modNamesInCabals args
    !packAndMod <- packageAndModNamesInCabals args

    let ids = nub $ fmap getId $ allMatches idExpr input
    let !toLinks = idToLink (concatMap strength $ packAndMod)
    let links = sort $ nub $ map toLinks ids
    let index = intercalate "\n" links

    return $ subElems $ subIndex index input
    where
        idChars   = "[^]]+"
        idExpr    = mkRegex $ "@\\[(" ++ idChars ++ ")\\]"
        indexExpr = mkRegex $ "@@@hslinks@@@"
        getId     = head . snd

        subElems a   = subRegex idExpr    a "[`\\1`][\\1]"
        subIndex i a = subRegex indexExpr a i

        -- This must be a subfunction of run for some reason (probably due to unsafe stuff below) 
        idToLink :: [(PackageName, ModuleName)] -> Identifier -> String
        idToLink !sources ident = do
            let vOrT = if isUpper (head ident) then "t" else "v"
            case whichModule (fmap snd sources) (wrapOp ident) of
                Left e -> "\n<!-- Unknown: " ++ ident ++ " " ++ e ++ "-->\n"
                Right modName -> 
                    -- TODO
                    -- TODO This should be optional
                    let package = fromJust $ whichPackage sources modName in
                        ""
                        ++ "[" ++ ident ++ "]: " ++ kPrefix 
                        ++ package 
                        ++ "/"
                        ++ replace '.' '-' modName ++ ".html" 
                        ++ "#" 
                        ++ vOrT ++ ":" ++ handleOp ident ++ ""

-- FIXME
kPrefix = "/docs/api/"

type PackageName = String
swap (x,y) = (y,x)
whichPackage sources x = lookup x (fmap swap sources)

-- If the given identifier is an operator, wrap it in parentheses
-- Necessary to make the search work
wrapOp :: Identifier -> Identifier
wrapOp []     = []
wrapOp as@(x:_)
    | isAlphaNum x = as
    | otherwise    = "(" ++ as ++ ")"

-- If the given identifier is an operator, escape it
handleOp :: Identifier -> Identifier
handleOp []     = []
handleOp as@(x:_)
    | isAlphaNum x = as
    | otherwise    = escapeOp as

-- Escape an operator a la Haddock
escapeOp = concatMap (\c -> "-" ++ show (ord c) ++ "-")


allMatches :: Regex -> String -> [(String, [String])]
allMatches reg str = case matchRegexAll reg str of
    Nothing                           -> []
    Just (before, match, after, subs) -> (match, subs) : allMatches reg after


-----------------------------------------------------------------------------------------

-- whichModule, modNamesInCabals

-- Given a set of modules, find the topmost module in which an identifier appears
-- A module is considered above another if it has fewer dots in its name. If the number of
-- dots are equal, use lexiographic order.
whichModule :: [ModuleName] -> Identifier -> Either String ModuleName
whichModule modNames ident = eitherMaybe ("No such identifier: " ++ ident)
    $ fmap (listToMaybe . sortBy bottomMost) modsWithIdent
    where
        mods = modsNamed modNames
        -- modules containing the identifier
        modsWithIdent = fmap (hasIdent ident) mods

modsNamed :: [ModuleName] -> Either String [(ModuleName, [Identifier])]
modsNamed = traverse modNamed

modNamed :: ModuleName -> Either String (ModuleName, [Identifier])
modNamed = modNamed'
modNamed' n = case identifiers n of {
    Left e    -> Left e ;
    Right ids -> Right (n, ids) ;
    }

hasIdent :: Identifier -> [(ModuleName, [Identifier])] -> [ModuleName]
hasIdent ident = fmap fst . filter (\(n,ids) -> ident `elem` ids)

-- | Get all the identifiers of a module
identifiers :: ModuleName -> Either String [Identifier]
identifiers = unsafePerformIO . identifiers'

identifiers' :: ModuleName -> IO (Either String [Identifier])
identifiers' modName = fmap getElemNames $ Hint.runInterpreter $ Hint.getModuleExports modName
    where
        getElemNames = either (Left . getError) Right . fmap (concatMap getModuleElem)
        getError = show

-- | Get all identifiers in a module element (names, class members, data constructors)
getModuleElem :: ModuleElem -> [Identifier]
getModuleElem (Fun a)      = [a]
getModuleElem (Class a as) = a:as
getModuleElem (Data a as)  = a:as

{-
modsInDir :: FilePath -> IO [ModuleName]
modsInDir dir = do
    dirList <- readProcess "find" [dir, "-type", "f", "-name", "*.hs"] ""
    let dirs = lines dirList
    let mods = fmap (pathToModName . dropBaseDir) dirs
    return mods
    where
        dropBaseDir   = drop (length dir)
        pathToModName = replace '/' '.' . dropWhile (not . isUpper) . dropLast 3

-}
packageAndModNamesInCabals :: [FilePath] -> IO [(PackageName, [ModuleName])]
packageAndModNamesInCabals paths = flip mapM paths $ \path -> do
    pn  <- packageNameInCabal path
    mns <- modNamesInCabal path
    return (pn, mns)


packageNameInCabals :: [FilePath] -> IO [PackageName]
packageNameInCabals = mapM packageNameInCabal

packageNameInCabal :: FilePath -> IO PackageName
packageNameInCabal path = do
    packageDesc <- PDP.readPackageDescription normal path
    return $ unPackageName $ P.pkgName $ PD.package $ PD.packageDescription packageDesc
        where
            unPackageName (P.PackageName x) = x

modNamesInCabals :: [FilePath] -> IO [[ModuleName]]
modNamesInCabals = mapM modNamesInCabal

modNamesInCabal :: FilePath -> IO [ModuleName]
modNamesInCabal path = do
    packageDesc <- PDP.readPackageDescription normal path

    -- TODO Why doesn't this work?
    -- case PD.library $ PD.packageDescription packageDesc of
    --     Nothing -> return []
    --     Just library -> return $ map unModName $ PD.exposedModules library
    --     where
    --         unModName = intercalate "." . components
        
    case PD.condLibrary packageDesc of
        Nothing      -> return []
        Just library -> return $ exposedModules library
        where
            exposedModules = fmap unModName . PD.exposedModules . foldCondTree
            unModName = intercalate "." . components
            foldCondTree (PD.CondNode x c comp) = x -- Ignore subtrees   

bottomMost :: ModuleName -> ModuleName -> Ordering
bottomMost a b = case comparing level a b of
    LT -> GT
    EQ -> a `compare` b
    GT -> LT
    where
        level = length . filter (== '.')

-----------------------------------------------------------------------------------------

eitherMaybe :: e -> Either e (Maybe a) -> Either e a
eitherMaybe e' = go
    where
        go (Left  e)         = Left e
        go (Right Nothing)   = Left e'
        go (Right (Just a))  = Right a

-- | @replace x y xs@ replaces all instances of a @x@ in a list @xs@ with @y@.
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map $ \z -> if z == x then y else z

takeLast :: Int -> [a] -> [a]
takeLast n = reverse . take n . reverse

dropLast :: Int -> [a] -> [a]
dropLast n = reverse . drop n . reverse


strength :: Functor f => (a, f b) -> f (a, b)
strength = fmap (fmap (\(x,y)->(y,x))) $ uncurry (flip strength')

strength' :: Functor f => f a -> b -> f (a,b)
strength' fa b = fmap (\a -> (a,b)) fa