{-# 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 [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']

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

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