diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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 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 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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/hslinks.cabal b/hslinks.cabal new file mode 100644 --- /dev/null +++ b/hslinks.cabal @@ -0,0 +1,32 @@ + +name: hslinks +version: 0.5 +cabal-version: >= 1.10 +author: Hans Hoglund +maintainer: Hans Hoglund +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 diff --git a/src/hslinks.hs b/src/hslinks.hs new file mode 100644 --- /dev/null +++ b/src/hslinks.hs @@ -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\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 + + + + +