hslinks 0.5 → 0.6
raw patch · 2 files changed
+115/−59 lines, 2 files
Files
- hslinks.cabal +1/−1
- src/hslinks.hs +114/−58
hslinks.cabal view
@@ -1,6 +1,6 @@ name: hslinks-version: 0.5+version: 0.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund <hans@hanshoglund.se>
src/hslinks.hs view
@@ -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<!-- Unknown: " ++ ident ++ " " ++ e ++ "-->\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