diff --git a/hslinks.cabal b/hslinks.cabal --- a/hslinks.cabal +++ b/hslinks.cabal @@ -1,6 +1,6 @@ name: hslinks -version: 0.5 +version: 0.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund diff --git a/src/hslinks.hs b/src/hslinks.hs --- a/src/hslinks.hs +++ b/src/hslinks.hs @@ -3,20 +3,25 @@ module Main where -import Data.Char -import Data.Maybe -import Data.MemoTrie -import Text.Regex -import System.Process -import System.IO -import System.IO.Unsafe -import System.Environment -import Language.Haskell.Interpreter -import Data.List (sort, sortBy, intercalate, nub) -import Distribution.PackageDescription.Parse -import Distribution.Verbosity (normal) -import Distribution.PackageDescription -import Distribution.ModuleName (components) +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 @@ -36,60 +41,76 @@ ------------------------------------------------------------------------------------------ -- | --- Given a list of cabal files, process input by replacing all text on the form +-- 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 - !modNames <- visibleModsInCabals args + -- !packageNames <- packageNameInCabals args + -- !modNames <- modNamesInCabals args + !packAndMod <- packageAndModNamesInCabals args - -- TODO generate the index let ids = nub $ fmap getId $ allMatches idExpr input - let !toLinks = idToLink modNames - let links = map toLinks ids + let !toLinks = idToLink (concatMap strength $ packAndMod) + let links = sort $ nub $ map toLinks ids let index = intercalate "\n" links - + return $ subElems $ subIndex index input - where + 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 - -- FIXME - kPrefix = "/docs/api/" - - idToLink :: [ModuleName] -> Identifier -> String - idToLink sources ident = do + -- 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 sources (wrapOp ident) of + case whichModule (fmap snd sources) (wrapOp ident) of Left e -> "\n\n" - Right modName -> "" - ++ "[" ++ ident ++ "]: " ++ kPrefix - ++ replace '.' '-' modName ++ ".html#" ++ vOrT ++ ":" ++ handleOp ident ++ "" + 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) ++ "-") @@ -97,17 +118,17 @@ allMatches reg str = case matchRegexAll reg str of Nothing -> [] Just (before, match, after, subs) -> (match, subs) : allMatches reg after - + ----------------------------------------------------------------------------------------- --- whichModule, visibleModsInCabals +-- 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) +whichModule modNames ident = eitherMaybe ("No such identifier: " ++ ident) $ fmap (listToMaybe . sortBy bottomMost) modsWithIdent where mods = modsNamed modNames @@ -115,7 +136,7 @@ modsWithIdent = fmap (hasIdent ident) mods modsNamed :: [ModuleName] -> Either String [(ModuleName, [Identifier])] -modsNamed modNames = sequence $ fmap modNamed modNames +modsNamed = traverse modNamed modNamed :: ModuleName -> Either String (ModuleName, [Identifier]) modNamed = modNamed' @@ -132,53 +153,81 @@ identifiers = unsafePerformIO . identifiers' identifiers' :: ModuleName -> IO (Either String [Identifier]) -identifiers' modName = fmap getElemNames $ runInterpreter $ getModuleExports modName +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) +-- | 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"] "" + dirList <- readProcess "find" [dir, "-type", "f", "-name", "*.hs"] "" let dirs = lines dirList let mods = fmap (pathToModName . dropBaseDir) dirs return mods - where + where dropBaseDir = drop (length dir) pathToModName = replace '/' '.' . dropWhile (not . isUpper) . dropLast 3 -visibleModsInCabals :: [FilePath] -> IO [ModuleName] -visibleModsInCabals = fmap concat . mapM visibleModsInCabal +-} +packageAndModNamesInCabals :: [FilePath] -> IO [(PackageName, [ModuleName])] +packageAndModNamesInCabals paths = flip mapM paths $ \path -> do + pn <- packageNameInCabal path + mns <- modNamesInCabal path + return (pn, mns) -visibleModsInCabal :: FilePath -> IO [ModuleName] -visibleModsInCabal path = do - packageDesc <- readPackageDescription normal path - case condLibrary packageDesc of - Nothing -> return [] - Just libTree -> return (fmap unModName $ exposedModules $ foldCondTree libTree) - where + +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 (CondNode x c comp) = x -- TODO subtrees + foldCondTree (PD.CondNode x c comp) = x -- Ignore subtrees bottomMost :: ModuleName -> ModuleName -> Ordering -bottomMost a b = case level a `compare` level b of +bottomMost a b = case comparing level a b of LT -> GT - EQ -> a `compare` b + EQ -> a `compare` b GT -> LT where level = length . filter (== '.') - + ----------------------------------------------------------------------------------------- eitherMaybe :: e -> Either e (Maybe a) -> Either e a eitherMaybe e' = go - where + where go (Left e) = Left e go (Right Nothing) = Left e' go (Right (Just a)) = Right a @@ -192,6 +241,13 @@ 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