HPath (empty) → 0.0.0
raw patch · 11 files changed
+540/−0 lines, 11 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, directory, filepath, haskell-src-exts, mtl, parsec, utf8-string
Files
- HPath.cabal +57/−0
- HPath/Cabal.hs +53/−0
- HPath/HaskellSrcExts.hs +57/−0
- HPath/HaskellSrcExts/Classes.hs +121/−0
- HPath/Hierarchy.hs +23/−0
- HPath/Parser/Lower.hs +64/−0
- HPath/Path.hs +48/−0
- LICENSE +28/−0
- Main.hs +78/−0
- README +7/−0
- Setup.hs +4/−0
+ HPath.cabal view
@@ -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+
+ HPath/Cabal.hs view
@@ -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)+
+ HPath/HaskellSrcExts.hs view
@@ -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)
+ HPath/HaskellSrcExts/Classes.hs view
@@ -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++
+ HPath/Hierarchy.hs view
@@ -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"++++
+ HPath/Parser/Lower.hs view
@@ -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 '\''++
+ HPath/Path.hs view
@@ -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])++
+ LICENSE view
@@ -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. +
+ Main.hs view
@@ -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 ++ " <Haskell identifier>"+ , ""+ , " 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 [])++
+ README view
@@ -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`.+
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+