{-# 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 bins <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO IO [String]
getAllBinaries
     mapM (\(String
name,String
bin) ->
             do uniqueName <- String -> Q Name
getUniqueName String
name
                return (FunD uniqueName
                             [Clause []
                                     (NormalB (AppE (VarE 'variadicProcess)
                                                    (LitE (StringL bin))))
                                     []]))
          (nubBy (on (==) fst)
                 (filter (not . null . fst)
                         (map (normalize &&& id) 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 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 inScope || candidate `elem` disallowedNames
        then getUniqueName (candidate ++ "'")
        else return (mkName 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 path <- String -> IO String
getEnv String
"PATH"
     fmap concat
          (forM (splitOn ":" path)
                (\String
dir ->
                   do exists <- String -> IO Bool
doesDirectoryExist String
dir
                      if exists
                         then do contents <- getDirectoryContents dir
                                 filterM (\String
file ->
                                            do exists' <- String -> IO Bool
doesFileExist (String
dir String -> String -> String
</> String
file)
                                               if exists'
                                                  then do perms <- getPermissions (dir </> file)
                                                          return (executable perms)
                                                  else return False)
                                         contents
                         else return []))