hslinks (empty) → 0.5
raw patch · 4 files changed
+261/−0 lines, 4 filesdep +Cabaldep +MemoTriedep +basesetup-changed
Dependencies added: Cabal, MemoTrie, base, hint, process, regex-compat
Files
- COPYING +26/−0
- Setup.hs +4/−0
- hslinks.cabal +32/−0
- src/hslinks.hs +199/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ hslinks.cabal view
@@ -0,0 +1,32 @@++name: hslinks+version: 0.5+cabal-version: >= 1.10+author: Hans Hoglund+maintainer: Hans Hoglund <hans@hanshoglund.se>+license: BSD3+license-file: COPYING+synopsis: Resolves links to Haskell identifiers.+category: Development+tested-with: GHC+build-type: Simple++description:+ To be written.++source-repository head+ type: git+ location: git://github.com/hanshoglund/hslinks.git++executable "hslinks"+ build-depends:+ base >= 4 && < 5,+ Cabal,+ hint,+ process,+ MemoTrie,+ regex-compat+ hs-source-dirs: src+ default-language: Haskell2010+ main-is:+ hslinks.hs
+ src/hslinks.hs view
@@ -0,0 +1,199 @@++{-# LANGUAGE BangPatterns #-}++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)++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+ !modNames <- visibleModsInCabals args++ -- TODO generate the index+ let ids = nub $ fmap getId $ allMatches idExpr input+ let !toLinks = idToLink modNames+ let links = 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++ -- FIXME+ kPrefix = "/docs/api/"++ idToLink :: [ModuleName] -> Identifier -> String+ idToLink sources ident = do+ let vOrT = if isUpper (head ident) then "t" else "v"+ case whichModule sources (wrapOp ident) of+ Left e -> "\n<!-- Unknown: " ++ ident ++ " " ++ e ++ "-->\n"+ Right modName -> ""+ ++ "[" ++ ident ++ "]: " ++ kPrefix+ ++ replace '.' '-' modName ++ ".html#" ++ vOrT ++ ":" ++ handleOp ident ++ ""++wrapOp :: Identifier -> Identifier+wrapOp [] = []+wrapOp as@(x:_)+ | isAlphaNum x = as+ | otherwise = "(" ++ as ++ ")"+ +handleOp :: Identifier -> Identifier+handleOp [] = []+handleOp as@(x:_)+ | isAlphaNum x = as+ | otherwise = escapeOp as++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, visibleModsInCabals++-- 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 modNames = sequence $ fmap modNamed modNames++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 $ runInterpreter $ 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++visibleModsInCabals :: [FilePath] -> IO [ModuleName]+visibleModsInCabals = fmap concat . mapM visibleModsInCabal++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 + unModName = intercalate "." . components+ foldCondTree (CondNode x c comp) = x -- TODO subtrees++bottomMost :: ModuleName -> ModuleName -> Ordering+bottomMost a b = case level a `compare` level 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+++++