diff --git a/HPath.cabal b/HPath.cabal new file mode 100644 --- /dev/null +++ b/HPath.cabal @@ -0,0 +1,57 @@ +name : HPath +version : 0.0.0 +category : Source Tools, Text +license : BSD3 +license-file : LICENSE +author : Jason Dusek +maintainer : HPath@solidsnack.be +homepage : http://github.com/solidsnack/HPath +synopsis : Extract Haskell declarations by name. +description : + Extract the source code for Haskell declarations by name, for use in + documentation. + + +cabal-version : >= 1.6 +build-type : Simple +extra-source-files : README + + +library + build-depends : base >= 2 && <= 4 + , containers + , filepath + , directory + , mtl + , parsec + , utf8-string >= 0.3 + , haskell-src-exts >= 1.3.5 + , Cabal >= 1.6 + exposed-modules : HPath.Cabal + HPath.HaskellSrcExts.Classes + HPath.HaskellSrcExts + HPath.Hierarchy + HPath.Parser.Lower + HPath.Path + extensions : StandaloneDeriving + NoMonomorphismRestriction + MultiParamTypeClasses + ParallelListComp + + +executable hpath + main-is : Main.hs + build-depends : base >= 2 && <= 4 + , containers + , filepath + , directory + , mtl + , parsec + , utf8-string >= 0.3 + , haskell-src-exts >= 1.3.5 + , Cabal >= 1.6 + extensions : StandaloneDeriving + NoMonomorphismRestriction + MultiParamTypeClasses + ParallelListComp + diff --git a/HPath/Cabal.hs b/HPath/Cabal.hs new file mode 100644 --- /dev/null +++ b/HPath/Cabal.hs @@ -0,0 +1,53 @@ + +module HPath.Cabal where + +import Prelude hiding (readFile, putStrLn) +import System.IO (stderr, stdin, stdout) +import System.IO.UTF8 +import System.FilePath +import Data.List +import Data.Maybe +import Control.Monad +import System.Directory + +import Distribution.Verbosity +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Language.Haskell.Extension + + + + +{-| Open a Cabal file in the given directory and tell us what extensions are + in play and what the source directories are. + -} +info :: FilePath -> IO ([Extension], [FilePath]) +info dir = do + cabal <- find + case cabal of + Nothing -> return ([], []) + Just file -> do + s <- readFile file + case parsePackageDescription s of + ParseFailed err -> do + hPutStrLn stderr ("Cabal error:" ++ "\n" ++ show err) + return ([], []) + ParseOk warns gpkg -> do + when ((not . null) warns) $ do + hPutStrLn stderr (unlines ("Cabal warnings:" : fmap show warns)) + return (extensions_and_sources gpkg) + where + find = one_cabal `fmap` getDirectoryContents dir + where + one_cabal = listToMaybe . filter (isSuffixOf ".cabal") + extensions_and_sources gpkg = concatP joined + where + joined = [lib] ++ exes ++ [([], [dir])] + exes = exe `fmap` condExecutables gpkg + exe = build_read . buildInfo . condTreeData . snd + lib = case condLibrary gpkg of + Nothing -> ([], []) + Just condTree -> (build_read . libBuildInfo . condTreeData) condTree + concatP pairs = (concatMap fst pairs, concatMap snd pairs) + build_read bi = (extensions bi, hsSourceDirs bi) + diff --git a/HPath/HaskellSrcExts.hs b/HPath/HaskellSrcExts.hs new file mode 100644 --- /dev/null +++ b/HPath/HaskellSrcExts.hs @@ -0,0 +1,57 @@ + +module HPath.HaskellSrcExts where + +import Prelude hiding (readFile) +import System.IO.UTF8 +import Data.Either +import Data.List + +import Language.Haskell.Extension as Cabal +import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts.Extension as HaskellSrcExts + +import HPath.Path +import HPath.HaskellSrcExts.Classes + + + + +search :: Path -> [Module SrcSpanInfo] -> [Decl SrcSpanInfo] +search path modules = concatMap (`declarations` qname path) modules + + +qname :: Path -> QName SrcSpanInfo +qname p@(Path u m name) = Qual note (ModuleName note mod) name' + where + name' = case name of + '(':_ -> Symbol note name + _ -> Ident note name + mod = intercalate "." (u ++ [m]) + note = SrcSpanInfo (SrcSpan (url p) 0 0 0 0) [] + + +extension_conversion :: [Cabal.Extension] -> [HaskellSrcExts.Extension] +extension_conversion = impliesExts . fmap (classifyExtension . show) + + +modules + :: [FilePath] + -> [HaskellSrcExts.Extension] + -> IO ( [Module SrcSpanInfo] + , ([(SrcLoc, String)], [(FilePath, IOError)])) +modules paths exts = do + runs <- sequence (fmap carefully paths) + let (exceptions, parses) = partitionEithers runs + (ok, err) = partition parses + return (ok, (err, exceptions)) + where + carefully f = catch (Right `fmap` read_mod f) paired_exc + where + paired_exc = return . Left . ((,) f) + read_mod f = parseModuleWithMode (mode f) `fmap` readFile f + mode f = ParseMode f exts False fixities + ParseMode _ _ _ fixities = defaultParseMode + partition = foldr part ([], []) + where + part (ParseOk t) (ok, err) = (t:ok, err) + part (ParseFailed loc s) (ok, err) = (ok, (loc, s):err) diff --git a/HPath/HaskellSrcExts/Classes.hs b/HPath/HaskellSrcExts/Classes.hs new file mode 100644 --- /dev/null +++ b/HPath/HaskellSrcExts/Classes.hs @@ -0,0 +1,121 @@ + +module HPath.HaskellSrcExts.Classes where + +import Data.List + +import Language.Haskell.Exts.Annotated + + + + +class (Annotated ast) => SearchModule ast where + declarations :: Module t -> ast t -> [Decl t] + + +instance SearchModule Name where + declarations mod name = case mod of + Module _ _ _ _ decls -> filter' decls + XmlHybrid _ _ _ _ decls _ _ _ _ -> filter' decls + _ -> [] + where + filter' = filter (`match` name) + + +instance SearchModule QName where + declarations m qname = + case qname of + UnQual _ name -> declarations m name + Qual _ mname name -> if module_name mname == module_name m + then declarations m name + else [] + _ -> [] + + +instance SearchModule Op where + declarations m (VarOp _ name) = declarations m name + declarations m (ConOp _ name) = declarations m name + + +instance SearchModule QOp where + declarations m (QVarOp _ qname) = declarations m qname + declarations m (QConOp _ qname) = declarations m qname + + + + +class (Annotated ast) => HasModuleName ast where + module_name :: ast t -> String + + +instance HasModuleName ModuleName where + module_name (ModuleName _ s) = s + + +instance HasModuleName ModuleHead where + module_name (ModuleHead _ name _ _) = module_name name + + +instance HasModuleName Module where + module_name (Module _ (Just head) _ _ _) = module_name head + module_name (XmlPage _ (ModuleName _ s) _ _ _ _ _) = s + module_name (XmlHybrid _ (Just head) _ _ _ _ _ _ _) = module_name head + module_name _ = "" + + +instance HasModuleName QName where + module_name (Qual _ name _) = module_name name + module_name _ = "" + + +instance HasModuleName QOp where + module_name (QVarOp _ qname) = module_name qname + module_name (QConOp _ qname) = module_name qname + + + + +class (Annotated ast) => MentionsNames ast where + match :: ast t -> Name t -> Bool + + +instance MentionsNames Decl where + match decl name = case decl of + TypeDecl _ d _ -> match d name + TypeFamDecl _ d _ -> match d name + DataDecl _ _ _ d _ _ -> match d name + GDataDecl _ _ _ d _ _ _ -> match d name + DataFamDecl _ _ d _ -> match d name + ClassDecl _ _ d _ _ -> match d name + InfixDecl _ _ _ ops -> any (`match` name) ops + TypeSig _ names _ -> any (`match` name) names + FunBind _ clauses -> any (`match` name) clauses + ForImp _ _ _ _ name' _ -> match name name' + ForExp _ _ _ name' _ -> match name name' + _ -> False + + +instance MentionsNames DeclHead where + match head name = case head of + DHead _ name' _ -> match name name' + DHInfix _ _ name' _ -> match name name' + DHParen _ head' -> match head' name + + +instance MentionsNames Op where + match op name = case op of + VarOp _ name' -> match name name' + ConOp _ name' -> match name name' + + +instance MentionsNames Match where + match m name = case m of + Match _ name' _ _ _ -> match name name' + InfixMatch _ _ n _ _ _ -> match name n + + +instance MentionsNames Name where + match (Ident _ s) (Ident _ s') = s == s' + match (Symbol _ s) (Symbol _ s') = s == s' + match _ _ = False + + diff --git a/HPath/Hierarchy.hs b/HPath/Hierarchy.hs new file mode 100644 --- /dev/null +++ b/HPath/Hierarchy.hs @@ -0,0 +1,23 @@ + +module HPath.Hierarchy where + +import Data.List + +import HPath.Path + + + + +{-| Produce file paths to search for this Haskell name, accomodating JHC style + paths as well as GHC style paths. The GHC style path comes first in order. + -} +paths :: Path -> [[Char]] +paths (Path mods m _) = reverse + [ name i t | i <- inits mods | t <- tails mods ] + where + name i t = intercalate "/" (i ++ [intercalate "." (t ++ [f])]) + f = m ++ ".hs" + + + + diff --git a/HPath/Parser/Lower.hs b/HPath/Parser/Lower.hs new file mode 100644 --- /dev/null +++ b/HPath/Parser/Lower.hs @@ -0,0 +1,64 @@ +{-| Parser for Haskell. Not complete and just parses strings to strings. + -} +module HPath.Parser.Lower where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Char +import Data.Char + + + + +varid = id_general small + +varsym = sym_general symbol +-- We aren't handling reserved operators correctly. + +conid = id_general large + +consym = sym_general colon +-- We aren't handling reserved operators correctly. + +tyvar = varid + +tycon = conid + +tycls = conid + +modid = conid + + +qualify p = do + mods <- sepEndBy modid (char '.') + ((,) mods) `fmap` p + +sym_general p = do + char '(' + c <- p + s <- many (choice [symbol, colon]) + char ')' + return ("(" ++ (c:s) ++ ")") + +id_general p = do + c <- p + s <- many (choice [small, large, digit, prime]) + return (c:s) + + +small = choice [satisfy isLower, char '_'] + +large = satisfy isUpper + +symbol = choice [satisfy (`elem` "!#$%&*+./<=>?@\\^|-~"), satisfy choosy] + where + choosy c = isSymbol c && not (elem c "_:\"'") + +colon = char ':' + +dash = char '-' + +dashes = dash >> dash >> many dash + +prime = char '\'' + + diff --git a/HPath/Path.hs b/HPath/Path.hs new file mode 100644 --- /dev/null +++ b/HPath/Path.hs @@ -0,0 +1,48 @@ + +module HPath.Path + ( Path(..) + , parse + , url + ) where + +import Data.List + +import qualified Text.ParserCombinators.Parsec (parse) +import Text.ParserCombinators.Parsec hiding (parse) +import Text.ParserCombinators.Parsec.Char + +import HPath.Parser.Lower + + + + +data Path = Path [String] String String +deriving instance Eq Path +deriving instance Ord Path +deriving instance Show Path + + +parse :: String -> Either ParseError Path +parse s = Text.ParserCombinators.Parsec.parse (qualified []) s s + + +qualified [] = modules [] +qualified (mod:mods) = do + choice + [ try (modules (mod:mods)) + , do + name <- choice [varid, varsym, conid, consym] + return (Path (reverse mods) mod name) + ] + + +modules mods = do + mod <- modid + char '.' + qualified (mod:mods) + + +url :: Path -> String +url (Path h m d) = "hpath://" ++ intercalate "." (h ++ [m, d]) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ + + ©2009 Jason Dusek. + + 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. + + . Names of the contributors to this software may not be used to endorse or + promote products derived from this software without specific prior written + permission. + + This software is provided by the 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 the contributors 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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,78 @@ +#!/usr/bin/env runhaskell + +import Prelude hiding (print) +import System.Directory +import System.FilePath +import Data.List +import Data.Either +import Control.Monad + +import System.Environment.UTF8 +import System.IO.UTF8 +import System.IO (stderr, stdin, stdout) +import Language.Haskell.Exts.Annotated.ExactPrint + +import HPath.Path +import HPath.Hierarchy +import qualified HPath.HaskellSrcExts as HaskellSrcExts +import qualified HPath.Cabal as Cabal + + + + +usage name = unlines + [ "USAGE: " ++ name ++ " " + , "" + , " Print the source text corresponding to the Haskell identifier, assuming" + , " we are in a project directory where this source can be found." + , "" + ] + + +main = do + args <- getArgs + usage' <- usage `fmap` getProgName + case args of + ["-h"] -> out usage' + ["-?"] -> out usage' + ["--help"] -> out usage' + [arg] -> case parse arg of + Left e -> do + err ("Not a path: " ++ arg ++ "\n" ++ show e) + err usage' + Right path -> do + err (url path) + dir <- getCurrentDirectory + (exts, roots) <- Cabal.info dir + let files = nub [ r p | p <- paths path, r <- roots ] + converted = nub (HaskellSrcExts.extension_conversion exts) + when ((not . null) converted) + (err (unlines ("Extensions:" : fmap show converted))) + (mods, errs) <- HaskellSrcExts.modules files converted + let parse_errors = fst errs + io_exceptions = snd errs + when ((not . null) parse_errors) + (err "Parse errors:" >> mapM_ (err . show) parse_errors) + when ((not . null) io_exceptions) + (err "File I/O errors:" >> mapM_ (err . show) io_exceptions) + if null mods + then err "No files corresponding to this identifier." >> err usage' + else do + let decls = HaskellSrcExts.search path (take 1 mods) + mapM_ (out . exactPrint') decls + _ -> err usage' + + +err s = hPutStrLn stderr s + + +out s = hPutStrLn stdout s + + +{-| We wrap 'exactPrint' to get rid of the many newlines it normally places in + front of the declaration (it positions the output on the same line as it + would have been on in the input). + -} +exactPrint' ep = dropWhile (=='\n') (exactPrint ep []) + + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,7 @@ + A tool to extract source code based on Haskell identifiers. For example, + + HPath.Parser.parse + + would extract all the source lines associated with the declaration `parse` + in the module `HPath.Parser`. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main = defaultMain +