{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module System.Command.QQ
(
sh_
, sh
, shell
, interpreter
, quoter
, callCommand
, substituteVars
, module System.Command.QQ.Embed
, module System.Command.QQ.Eval
) where
import Data.Char (isLower, isUpper)
import Data.Maybe (fromMaybe)
import Language.Haskell.TH (Q, Exp)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
import System.Command.QQ.Embed
import System.Command.QQ.Eval
sh :: QuasiQuoter
sh = quoter $ \string -> do
shellEx <- TH.runIO (getEnvDefault "/bin/sh" "SHELL")
callCommand shellEx ["-c"] string
sh_ :: QuasiQuoter
sh_ = quoter $ \string -> do
shellEx <- TH.runIO (getEnvDefault "/bin/sh" "SHELL")
callCommand_ shellEx ["-c"] string
shell :: FilePath -> QuasiQuoter
shell path = quoter (callCommand path ["-c"])
interpreter :: FilePath -> QuasiQuoter
interpreter path = quoter (callCommand path ["-e"])
quoter :: (String -> Q Exp) -> QuasiQuoter
quoter quote = QuasiQuoter
{ quoteExp = quote
, quotePat = failure "patterns"
, quoteType = failure "types"
, quoteDec = failure "declarations"
}
where
failure kind =
error ("this quasiquoter does not support splicing " ++ kind)
callCommand
:: FilePath
-> [String]
-> String
-> Q Exp
callCommand path args string =
[e| eval path (args ++ [$(substituteVars string)]) |]
callCommand_
:: FilePath
-> [String]
-> String
-> Q Exp
callCommand_ path args string =
[e| eval path (args ++ [$(substituteVars string)]) :: IO () |]
substituteVars :: String -> Q Exp
substituteVars = raw where
raw, var :: String -> Q Exp
raw str = case break (== '\\') str of
(before, '\\' : '\\' : after) -> [e| before ++ '\\' : $(raw after) |]
(before, '\\' : '#' : '{' : after) -> [e| before ++ '#' : '{' : $(raw after) |]
(_, _) -> case break (== '#') str of
(before, '#' : '{' : after) -> [e| before ++ $(var after) |]
(before, '#' : '\\' : after) -> [e| before ++ '#' : $(raw after) |]
(before, '#' : after) -> [e| before ++ '#' : $(raw after) |]
(before, []) -> [e| before |]
_ -> fail "Should never happen"
var (break (== '}') -> parts) = case parts of
(b : efore, '}' : after)
| isLower b -> external (TH.VarE (TH.mkName (b:efore))) after
| isUpper b -> external (TH.ConE (TH.mkName (b:efore))) after
| Just i <- readMaybe (b:efore) -> external (TH.LitE (TH.IntegerL i)) after
| Just d <- readMaybe (b:efore) -> external (TH.LitE (TH.RationalL (toRational (d :: Double)))) after
| Just c <- readMaybe (b:efore) -> external (TH.LitE (TH.CharL c)) after
| Just s <- readMaybe (b:efore) -> external (TH.LitE (TH.StringL s)) after
(before, _) -> fail ("Invalid name: " ++ before)
external :: Exp -> String -> Q Exp
external e after = [e| embed $(return e) ++ $(raw after) |]
getEnvDefault
:: String
-> String
-> IO String
getEnvDefault def = fmap (fromMaybe def) . lookupEnv