{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

-- | Generate top-level names for binaries.

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

-- | Generate top-level names for all binaries in PATH.
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']

-- | Get a version of the given name available to be bound.
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)

-- | Get a list of all binaries in PATH.
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 []))