modulespection (empty) → 0.1.0.0
raw patch · 4 files changed
+258/−0 lines, 4 filesdep +basedep +ghcdep +ghc-pathssetup-changed
Dependencies added: base, ghc, ghc-paths, template-haskell
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- modulespection.cabal +78/−0
- src/Language/Haskell/TH/Module/Magic.hs +148/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jonathan Fischoff++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 Jonathan Fischoff nor the names of other+ 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 THE COPYRIGHT+OWNER OR 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ modulespection.cabal view
@@ -0,0 +1,78 @@+-- Initial modulespection.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: modulespection+version: 0.1.0.0+synopsis: Template Haskell introspecting a modules declarations+description: + Collect all of the declarations in a module using Template Haskell (via the GHC API). + . + One can either get all the names, or just the declarations (only type declarations+ are supported right now).+ .+ Here is a quick example+ . + > import Language.Haskell.TH.Module.Magic (names)+ > + > data Test = Test Int+ > newtype OtherTest = OtherTest Test+ > + > someFunction :: String -> String+ > someFunction = id+ > + > -- 'names' is Template Haskell function that will collect all of the + > -- toplevel declaration names of the current file.+ > names >>= runIO . print >> return []+ .+ Which will spew the following when compiling.+ .+ > [Test,OtherTest,someFunction]+ . + There is also 'declarations' which can be used, for example, to make sure that all+ types have @ToJSON@/@FromJSON@ instances. + .+ > import Data.Aeson.TH (deriveJSON, defaultOptions)+ > import MonadUtils (concatMapM)+ > import Language.Haskell.TH.Module.Magic (names)+ > + > data Test = Test Int+ > newtype OtherTest = OtherTest Test+ >+ > concatMapM (deriveJSON defaultOptions) =<< declarations+ .+ Which will makes the JSON instances for Test and OtherTest and any other types+ added to the file.+ .+ You can also do the same thing for an existing module.+ .+ > import Data.Aeson.TH (deriveJSON, defaultOptions)+ > import MonadUtils (concatMapM)+ > import Language.Haskell.TH.Module.Magic (names)+ > import Data.Monoid+ > + > concatMapM (deriveJSON defaultOptions) =<< moduleDeclarations "Data.Monoid"+ .+ Which will build instances for all the types in "Data.Monoid".++license: BSD3+license-file: LICENSE+author: Jonathan Fischoff+maintainer: jonathangfischoff@gmail.com+homepage: https://github.com/jfischoff/modulespection+-- copyright: +category: Language+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Language.Haskell.TH.Module.Magic+ -- other-modules: + other-extensions: LambdaCase+ , FlexibleInstances+ build-depends: base >=4.6 && <4.7+ , template-haskell >=2.7 && <2.9+ , ghc-paths >=0.1 && <0.2+ , ghc+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Language/Haskell/TH/Module/Magic.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.Haskell.TH.Module.Magic + ( -- * Name Introspection+ names+ , moduleNames+ -- * Declaration Introspection+ , declarations+ , moduleDeclarations+ ) where+import Language.Haskell.TH as TH+import Data.Maybe+import GHC+import Module+import GHC.Paths ( libdir )+import DynFlags +import Name as Name+import RdrName +import MonadUtils+import HsDecls as HsDecls+import SrcLoc+import Bag+import Control.Monad+import Data.Monoid++-- | Get all the top level declarations of the current file.+-- All names are returned whether they are exported or not.+names :: Q [TH.Name]+names = moduleNames . loc_filename =<< location++-- | Get all the top level names of a given module. +-- If a file path is used, all names, exported and internal+-- are returned. If a module name is used, only the exported+-- names are returned.+moduleNames :: String -> Q [TH.Name]+moduleNames target = runIO $ + defaultErrorHandler + defaultFatalMessager + defaultFlushOut + $ do+ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags+ lookupModuleNames target++-- | Look up a name, and get out the declaration +-- or return nothing+nameToMaybeDec :: TH.Name -> Q (Maybe Dec)+nameToMaybeDec name = do+ info <- reify name+ return $ case info of+ TyConI dec -> Just dec+ _ -> Nothing+ +-- | Get all the type declarations of the current file. +-- Function and pattern declarations are ignored ... for now.+declarations :: Q [Dec]+declarations = mapMaybeM nameToMaybeDec =<< names++-- | Get all the top level names of a given module. +-- If a file path is used, all names, exported and internal+-- are returned. If a module name is used, only the exported+-- names are returned.+-- Function and pattern declarations are ignored ... for now.+moduleDeclarations :: String -> Q [Dec]+moduleDeclarations = mapMaybeM nameToMaybeDec <=< moduleNames ++-- | Either try to parse a source file or if the module is+-- part of library, look it up and browse the contents+lookupModuleNames :: GhcMonad m => String -> m [TH.Name]+lookupModuleNames mName = do + target <- targetId <$> guessTarget mName Nothing+ case target of+ TargetModule moduleName -> getExistingModuleNames + =<< lookupModule moduleName Nothing+ TargetFile filePath _ -> parseFile filePath++-- | Turn ErrorMessages into a String+errString :: Show a => Bag a -> String +errString = unlines + . map show + . foldBag (<>) (:[]) []++-- | Parse a file and collect all of the declarations names+parseFile :: GhcMonad m => FilePath -> m [TH.Name]+parseFile filePath = do+ dflags <- getDynFlags+ src <- liftIO $ readFile filePath + let (warns, L _ hsModule) = + either (error . errString) id+ $ parser src dflags filePath+ + names = mapMaybe getNameMaybe $ hsmodDecls hsModule+ + return $ map rdrNameToName names++showModuleName :: Module -> String+showModuleName = moduleNameString . moduleName++getExistingModuleNames :: GhcMonad m => Module -> m [TH.Name]+getExistingModuleNames modl = do+ moduleInfo <- getModuleInfo modl+ case moduleInfo of+ Nothing -> error $ "modulespection: Failed to find module info for "+ <> showModuleName modl+ <> " in getExistingModuleNames"+ Just mod_info -> fmap (map (occNameToName . nameOccName . getName))+ . mapMaybeM lookupName + $ modInfoExports mod_info++-- | Simple Class for getting the name of things+class GetNameMaybe a where+ getNameMaybe :: a -> Maybe RdrName++instance GetNameMaybe (HsDecl RdrName) where+ getNameMaybe = \case + TyClD x -> getNameMaybe x+ HsDecls.ValD x -> getNameMaybe x+ _ -> Nothing++instance GetNameMaybe (TyClDecl RdrName) where+ getNameMaybe = \case+ ForeignType x _ -> getNameMaybe x+ x@(TyFamily {}) -> getNameMaybe $ tcdLName x+ TyDecl x _ _ _ -> getNameMaybe x+ x@(ClassDecl {}) -> getNameMaybe $ tcdLName x++instance GetNameMaybe (HsBindLR RdrName RdrName) where+ getNameMaybe = \case + x@(FunBind {}) -> getNameMaybe $ fun_id x + _ -> Nothing++instance GetNameMaybe a => GetNameMaybe (GenLocated SrcSpan a) where+ getNameMaybe (L _ x) = getNameMaybe x ++instance GetNameMaybe RdrName where+ getNameMaybe = Just++-- Name Utils+occNameToName :: OccName -> TH.Name+occNameToName = mkName . occNameString ++rdrNameToName :: RdrName -> TH.Name+rdrNameToName = \case + RdrName.Unqual x -> occNameToName x+ RdrName.Qual _ x -> occNameToName x+ RdrName.Orig _ x -> occNameToName x+ RdrName.Exact x -> occNameToName $ nameOccName x