module Language.Haskell.Extract (
functionExtractor,
functionExtractorMap,
locationModule
) where
import Language.Haskell.TH
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts (parseFileContentsWithMode)
import Language.Haskell.Exts.Syntax
import Text.Regex.Posix
import Data.Maybe
import Data.List
import Language.Haskell.Exts.Extension
extractAllFunctions :: String -> String-> [String]
extractAllFunctions pattern file =
nub $ filter (\f->f=~pattern::Bool) $ map (fst . head . lex) $ lines file
parsedModule moduleCode =
let pMod = parseFileContentsWithMode (defaultParseMode { extensions = knownExtensions } ) moduleCode
moduleOrDefault (ParseFailed _ _) = Module (SrcLoc "unknown" 1 1) (ModuleName "unknown") [] Nothing Nothing [] []
moduleOrDefault (ParseOk m) = m
in moduleOrDefault pMod
allFunctions = onlyJust extractNameOfFunctionFromDecl . hsModuleDecls
allMatchingFunctions pattern = filter (\f->f=~pattern::Bool) . allFunctions
extractNameOfFunctionFromDecl :: Decl -> Maybe String
extractNameOfFunctionFromDecl (PatBind _ (PVar (Ident n)) _ _ _ ) = Just n
extractNameOfFunctionFromDecl (FunBind ms) = Just $ head $ [n | (Language.Haskell.Exts.Syntax.Match _ (Ident n) _ _ _ _) <- ms]
extractNameOfFunctionFromDecl _ = Nothing
onlyJust f = map fromJust . filter isJust . map f
hsModuleDecls (Module _ _ _ _ _ _ d) = d
functionExtractor :: String -> ExpQ
functionExtractor pattern =
do loc <- location
moduleCode <- runIO $ readFile $ loc_filename loc
let functions = extractAllFunctions pattern moduleCode
makePair n = TupE [ LitE $ StringL n , VarE $ mkName n]
return $ ListE $ map makePair functions
functionExtractorMap :: String -> ExpQ -> ExpQ
functionExtractorMap pattern funcName =
do loc <- location
moduleCode <- runIO $ readFile $ loc_filename loc
let functions :: [String]
functions = extractAllFunctions pattern moduleCode
fn <- funcName
let makePair n = AppE (AppE (fn) (LitE $ StringL n)) (VarE $ mkName n)
return $ ListE $ map makePair functions
locationModule :: ExpQ
locationModule =
do loc <- location
return $ LitE $ StringL $ loc_module loc