| external-reality | 8f34d23 | 2014-02-22 21:35:47 -0500 | [diff] [blame^] | 1 | module Lambda ( freeVariables |
| 2 | , lambdaArgs |
| 3 | , lambdaBody |
| 4 | ) where |
| 5 | |
| 6 | import Control.Monad |
| 7 | import Data.Generics.Aliases |
| 8 | import Data.Generics.Schemes |
| 9 | import Data.List |
| 10 | import Language.Haskell.Exts |
| 11 | ------------------------------------------------------------------------------ |
| 12 | import HDevTools |
| 13 | import Client |
| 14 | |
| 15 | ------------------------------------------------------------------------------ |
| 16 | freeVariables :: FilePath -> FilePath -> FilePath -> String -> Client -> String -> IO String |
| 17 | freeVariables srcPath pkgConfigPath cabalFilePath buildTargetName client code = case parseExp code of |
| 18 | ParseOk ast -> do |
| 19 | names <- dropModuleVariableNames srcPath |
| 20 | pkgConfigPath |
| 21 | cabalFilePath |
| 22 | buildTargetName $ extractFreeVariables ast |
| 23 | return . dropCommas $ show names |
| 24 | _ -> return "Error parsing freeVars" |
| 25 | |
| 26 | ------------------------------------------------------------------------------ |
| 27 | lambdaBody :: String -> String |
| 28 | lambdaBody code = case parseExp code of |
| 29 | ParseOk ast -> show . extractLambdaBody $ ast |
| 30 | _ -> "[]" |
| 31 | |
| 32 | ------------------------------------------------------------------------------ |
| 33 | lambdaArgs :: String -> String |
| 34 | lambdaArgs code = case parseExp code of |
| 35 | ParseOk ast -> extractLambdaArgs ast |
| 36 | _ -> "[]" |
| 37 | |
| 38 | ------------------------------------------------------------------------------ |
| 39 | extractLambdaArgs :: Exp -> String |
| 40 | extractLambdaArgs (Lambda _ ast _) = dropCommas . show $ allNames ast |
| 41 | extractLambdaArgs _ = "[]" |
| 42 | |
| 43 | ------------------------------------------------------------------------------ |
| 44 | allVariables :: GenericQ [Exp] |
| 45 | allVariables = listify isVar |
| 46 | |
| 47 | ------------------------------------------------------------------------------ |
| 48 | allBindings :: GenericQ [Pat] |
| 49 | allBindings = listify isBinding |
| 50 | |
| 51 | ------------------------------------------------------------------------------ |
| 52 | allNames :: GenericQ [String] |
| 53 | allNames = everything (++) ([] `mkQ` fmap (: []) getStringFromName) |
| 54 | |
| 55 | ------------------------------------------------------------------------------ |
| 56 | isVar :: Exp -> Bool |
| 57 | isVar (Var _) = True |
| 58 | isVar _ = False |
| 59 | |
| 60 | ------------------------------------------------------------------------------ |
| 61 | isBinding :: Pat -> Bool |
| 62 | isBinding (PVar _) = True |
| 63 | isBinding _ = False |
| 64 | |
| 65 | ------------------------------------------------------------------------------ |
| 66 | getStringFromName :: Name -> String |
| 67 | getStringFromName (Symbol str) = str |
| 68 | getStringFromName (Ident str) = str |
| 69 | |
| 70 | ------------------------------------------------------------------------------ |
| 71 | dropCommas :: String -> String |
| 72 | dropCommas = filter (/= ',') |
| 73 | |
| 74 | ------------------------------------------------------------------------------ |
| 75 | extractLambdaBody :: Exp -> String |
| 76 | extractLambdaBody (Lambda _ _ ast) = prettyPrint ast |
| 77 | extractLambdaBody _ = "[]" |
| 78 | |
| 79 | ------------------------------------------------------------------------------ |
| 80 | extractFreeVariables :: GenericQ [String] |
| 81 | extractFreeVariables ast = allNames (allVariables ast) \\ |
| 82 | allNames (allBindings ast) |
| 83 | |
| 84 | ------------------------------------------------------------------------------ |
| 85 | dropModuleVariableNames :: FilePath -> FilePath -> FilePath -> String -> [String] -> IO [String] |
| 86 | dropModuleVariableNames srcPath pkgConfigPath cabalFilePath buildTargetName = |
| 87 | filterM $ (liftM not) . isInModuleScope srcPath |
| 88 | pkgConfigPath |
| 89 | cabalFilePath |
| 90 | buildTargetName |