{-# 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 [FilePath]
bins <- IO [FilePath] -> Q [FilePath]
forall a. IO a -> Q a
runIO IO [FilePath]
getAllBinaries
((FilePath, FilePath) -> Q Dec)
-> [(FilePath, FilePath)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(name :: FilePath
name,bin :: FilePath
bin) ->
do Name
uniqueName <- FilePath -> Q Name
getUniqueName FilePath
name
Dec -> Q Dec
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 (FilePath -> Lit
StringL FilePath
bin))))
[]]))
(((FilePath, FilePath) -> (FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((FilePath -> FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst)
(((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((FilePath, FilePath) -> Bool) -> (FilePath, FilePath) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst)
((FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalize (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> (FilePath, FilePath)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& FilePath -> FilePath
forall a. a -> a
id) [FilePath]
bins)))
where normalize :: FilePath -> FilePath
normalize = FilePath -> FilePath
uncapitalize (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
go
where go :: FilePath -> FilePath
go (c :: Char
c:cs :: FilePath
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' =
case FilePath -> FilePath
go FilePath
cs of
(z :: Char
z:zs :: FilePath
zs) -> Char -> Char
toUpper Char
z Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
zs
[] -> []
| Bool -> Bool
not (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Char -> Char
toLower Char
c) FilePath
allowed) = FilePath -> FilePath
go FilePath
cs
| Bool
otherwise = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
go FilePath
cs
go [] = []
uncapitalize :: FilePath -> FilePath
uncapitalize (c :: Char
c:cs :: FilePath
cs)
| Char -> Bool
isDigit Char
c = '_' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
cs
| Bool
otherwise = Char -> Char
toLower Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
cs
uncapitalize [] = []
allowed :: FilePath
allowed =
['a' .. 'z'] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
['0' .. '9']
getUniqueName :: String -> Q Name
getUniqueName :: FilePath -> Q Name
getUniqueName candidate :: FilePath
candidate =
do Bool
inScope <- Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
recover (Bool -> Q Bool
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 (FilePath -> Name
mkName FilePath
candidate))
Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
if Bool
inScope Bool -> Bool -> Bool
|| FilePath
candidate FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "import" Bool -> Bool -> Bool
|| FilePath
candidate FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "type"
then FilePath -> Q Name
getUniqueName (FilePath
candidate FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'")
else Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Name
mkName FilePath
candidate)
getAllBinaries :: IO [FilePath]
getAllBinaries :: IO [FilePath]
getAllBinaries =
do FilePath
path <- FilePath -> IO FilePath
getEnv "PATH"
([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn ":" FilePath
path)
(\dir :: FilePath
dir ->
do Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
if Bool
exists
then do [FilePath]
contents <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
(FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\file :: FilePath
file ->
do Bool
exists' <- FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file)
if Bool
exists'
then do Permissions
perms <- FilePath -> IO Permissions
getPermissions (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
executable Permissions
perms)
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
[FilePath]
contents
else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []))