{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Data.Conduit.Shell.TH
(generateBinaries)
where
import Data.Conduit.Shell.Variadic
import Control.Arrow
import Control.Monad
import Data.Char
import Data.Function
import Data.List
import Data.List.Split
import Language.Haskell.TH
import System.Directory
import System.Environment
import System.FilePath
generateBinaries :: Q [Dec]
generateBinaries :: Q [Dec]
generateBinaries =
do [String]
bins <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO IO [String]
getAllBinaries
((String, String) -> Q Dec) -> [(String, String)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(String
name,String
bin) ->
do Name
uniqueName <- String -> Q Name
getUniqueName String
name
Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Clause] -> Dec
FunD Name
uniqueName
[[Pat] -> Body -> [Dec] -> Clause
Clause []
(Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'variadicProcess)
(Lit -> Exp
LitE (String -> Lit
StringL String
bin))))
[]]))
(((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((String -> String -> Bool)
-> ((String, String) -> String)
-> (String, String)
-> (String, String)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String, String) -> String
forall a b. (a, b) -> a
fst)
(((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, String) -> Bool) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst)
((String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalize (String -> String)
-> (String -> String) -> String -> (String, String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& String -> String
forall a. a -> a
id) [String]
bins)))
where normalize :: String -> String
normalize = String -> String
uncapitalize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go
where go :: String -> String
go (Char
c:String
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' =
case String -> String
go String
cs of
(Char
z:String
zs) -> Char -> Char
toUpper Char
z Char -> String -> String
forall a. a -> [a] -> [a]
: String
zs
[] -> []
| Bool -> Bool
not (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Char -> Char
toLower Char
c) String
allowed) = String -> String
go String
cs
| Bool
otherwise = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
cs
go [] = []
uncapitalize :: String -> String
uncapitalize (Char
c:String
cs)
| Char -> Bool
isDigit Char
c = Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
| Bool
otherwise = Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
uncapitalize [] = []
allowed :: String
allowed =
[Char
'a' .. Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++
[Char
'0' .. Char
'9']
getUniqueName :: String -> Q Name
getUniqueName :: String -> Q Name
getUniqueName String
candidate =
do Bool
inScope <- Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
recover (Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
(do Q Info -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Name -> Q Info
reify (String -> Name
mkName String
candidate))
Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
if Bool
inScope Bool -> Bool -> Bool
|| String
candidate String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
disallowedNames
then String -> Q Name
getUniqueName (String
candidate String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
else Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Name
mkName String
candidate)
where
disallowedNames :: [String]
disallowedNames = [
String
"class",
String
"data",
String
"do",
String
"import",
String
"type"
]
getAllBinaries :: IO [FilePath]
getAllBinaries :: IO [String]
getAllBinaries =
do String
path <- String -> IO String
getEnv String
"PATH"
([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([String] -> (String -> IO [String]) -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
":" String
path)
(\String
dir ->
do Bool
exists <- String -> IO Bool
doesDirectoryExist String
dir
if Bool
exists
then do [String]
contents <- String -> IO [String]
getDirectoryContents String
dir
(String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\String
file ->
do Bool
exists' <- String -> IO Bool
doesFileExist (String
dir String -> String -> String
</> String
file)
if Bool
exists'
then do Permissions
perms <- String -> IO Permissions
getPermissions (String
dir String -> String -> String
</> String
file)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
executable Permissions
perms)
else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
[String]
contents
else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []))