-- | We provide a format-string-like way of describing how to call particular
-- tools.  Thus the input is
-- (1) a particular format string
-- (2) a partial map from upper-case letters to strings; we call these strings
--     the _insert_ strings.
-- We map the format string to an output string in which combinations
-- of the form
-- %[upper-case-letter]
-- in the format string are replaced by the corresponding insert string; if no
-- such string exists this is an error.
--
-- We also provide a mechanism for "escaping" the insert strings.
-- Specifically, there is a fixed partial map from lower-case letters to
-- functions :: String -> String; these functions we call the transformers.
-- For a combination of the form
-- %[lower-case-letter-1]...[lower-case-letter-n][upper-case-letter]
-- we take the insert string corresponding to upper-case-letter, and then
-- pass it through the transformers corresponding to lower-case-letter-n,
-- and so on down to the transformer corresponding to lower-case-letter-1.
--
-- Instead of [upper-case-letter] we may also write "%" in which case the
-- insert string is just "%"; thus "%%" transforms to "%".
--
-- Sections of the input string not containing % are left untouched.
--
-- Defined transformers with their corresponding letters:
--    b  transformer suitable for escaping bash strings quoted with ".
--    e  transformer suitable for escaping emacs lisp strings quoted with ".
-- None of these transformers insert the closing or end quotes, allowing you
-- to use them in the middle of strings.
--
-- Other transformers will be added as the need arises.
module Util.CommandStringSub(
   CompiledFormatString,
      -- This represents a format string in which all the transformers and
      -- escapes (apart from escaped upper-case letters) have been parsed.

   -- compileFormatString and runFormatString split the computation into
   -- two stages so we can save a bit of time if the same format string is
   -- used more than once.
   compileFormatString,
      -- :: String -> WithError CompiledFormatString
   runFormatString,
      -- :: CompiledFormatString -> (Char -> Maybe String) -> WithError String

   -- doFormatString does everything at once, throwing an error if necessary.
   doFormatString,
      -- :: String -> (Char -> Maybe String) -> String


   -- Some transformers we export for use as simple Haskell functions
   -- NB - these do not delimit the input strings.
   emacsEscape, -- :: String -> String
   bashEscape, -- :: String -> String
   ) where

import Data.Char

import Util.Computation

-- --------------------------------------------------------------------------
-- The datatypes
-- --------------------------------------------------------------------------

data FormatItem =
      Unescaped String
   |  Escaped (String -> String) Char

newtype CompiledFormatString = CompiledFormatString [FormatItem]

-- --------------------------------------------------------------------------
-- compileFormatString
-- --------------------------------------------------------------------------

compileFormatString :: String -> WithError CompiledFormatString
compileFormatString :: String -> WithError CompiledFormatString
compileFormatString String
str =
   case String -> Maybe (String, String)
splitToDollar String
str of
      Maybe (String, String)
Nothing -> CompiledFormatString -> WithError CompiledFormatString
forall a. a -> WithError a
hasValue (String -> CompiledFormatString -> CompiledFormatString
prependLiteral String
str ([FormatItem] -> CompiledFormatString
CompiledFormatString []))
      Just (String
s1,String
s2) ->
         ((Char, String -> String, WithError CompiledFormatString)
 -> WithError CompiledFormatString)
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
-> WithError CompiledFormatString
forall a b. (a -> WithError b) -> WithError a -> WithError b
mapWithError'
            (\ (Char
ch,String -> String
transformer,WithError CompiledFormatString
withError) ->
               (CompiledFormatString -> CompiledFormatString)
-> WithError CompiledFormatString -> WithError CompiledFormatString
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError
                  (\ (CompiledFormatString [FormatItem]
l) ->
                     String -> CompiledFormatString -> CompiledFormatString
prependLiteral String
s1
                        ([FormatItem] -> CompiledFormatString
CompiledFormatString (((String -> String) -> Char -> FormatItem
Escaped String -> String
transformer Char
ch)FormatItem -> [FormatItem] -> [FormatItem]
forall a. a -> [a] -> [a]
:[FormatItem]
l))
                     )
                  WithError CompiledFormatString
withError
               )
            (String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
compileFromEscape String
s2)

-- | Return portion up to (not including) first %, and portion after it.
splitToDollar :: String -> Maybe (String,String)
splitToDollar :: String -> Maybe (String, String)
splitToDollar String
"" = Maybe (String, String)
forall a. Maybe a
Nothing
splitToDollar (Char
'%':String
rest) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"",String
rest)
splitToDollar (Char
c:String
rest) = ((String, String) -> (String, String))
-> Maybe (String, String) -> Maybe (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (String
s1,String
s2) -> (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s1,String
s2)) (String -> Maybe (String, String)
splitToDollar String
rest)

prependLiteral :: String -> CompiledFormatString -> CompiledFormatString
prependLiteral :: String -> CompiledFormatString -> CompiledFormatString
prependLiteral String
"" CompiledFormatString
compiledFormatString = CompiledFormatString
compiledFormatString
prependLiteral String
s (CompiledFormatString [FormatItem]
l) =
   [FormatItem] -> CompiledFormatString
CompiledFormatString (String -> FormatItem
Unescaped String
sFormatItem -> [FormatItem] -> [FormatItem]
forall a. a -> [a] -> [a]
:[FormatItem]
l)

compileFromEscape :: String
   -> WithError (Char,String -> String,WithError CompiledFormatString)
compileFromEscape :: String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
compileFromEscape String
"" = String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
forall a. String -> WithError a
hasError String
"Format string ends unexpectedly"
compileFromEscape (Char
c:String
rest) =
   if Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' then (Char, String -> String, WithError CompiledFormatString)
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
forall a. a -> WithError a
hasValue (Char
c,String -> String
forall a. a -> a
id,String -> WithError CompiledFormatString
compileFormatString String
rest)
   else case Char
c of
      Char
'e' -> (String -> String)
-> String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
mapEscapeFunction String -> String
emacsEscape String
rest
      Char
'b' -> (String -> String)
-> String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
mapEscapeFunction String -> String
bashEscape String
rest
      Char
_ ->
         let
            compiledRest :: WithError CompiledFormatString
compiledRest = String -> WithError CompiledFormatString
compileFormatString String
rest
            e :: a
e = String -> a
forall a. HasCallStack => String -> a
error String
"Attempt to run bad format string"
            restFaked :: WithError (a, b, WithError CompiledFormatString)
restFaked = (a, b, WithError CompiledFormatString)
-> WithError (a, b, WithError CompiledFormatString)
forall a. a -> WithError a
hasValue (a
forall a. a
e,b
forall a. a
e,WithError CompiledFormatString
compiledRest)
            message :: String
message = if Char -> Bool
isLower Char
c then
               String
"Transformer character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not recognised."
               else String
"Unexpected character "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in format string."
         in
            ((Any, (Char, String -> String, WithError CompiledFormatString))
 -> (Char, String -> String, WithError CompiledFormatString))
-> WithError
     (Any, (Char, String -> String, WithError CompiledFormatString))
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError (Any, (Char, String -> String, WithError CompiledFormatString))
-> (Char, String -> String, WithError CompiledFormatString)
forall a b. (a, b) -> b
snd (WithError Any
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
-> WithError
     (Any, (Char, String -> String, WithError CompiledFormatString))
forall a b. WithError a -> WithError b -> WithError (a, b)
pairWithError (String -> WithError Any
forall a. String -> WithError a
hasError String
message) WithError (Char, String -> String, WithError CompiledFormatString)
forall a b. WithError (a, b, WithError CompiledFormatString)
restFaked)

mapEscapeFunction :: (String -> String) -> String ->
   WithError (Char,String -> String,WithError CompiledFormatString)
mapEscapeFunction :: (String -> String)
-> String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
mapEscapeFunction String -> String
escapeFunction String
s =
   ((Char, String -> String, WithError CompiledFormatString)
 -> (Char, String -> String, WithError CompiledFormatString))
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError
      (\ (Char
ch,String -> String
transformer,WithError CompiledFormatString
rest) -> (Char
ch,String -> String
escapeFunction (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
transformer,WithError CompiledFormatString
rest))
      (String
-> WithError
     (Char, String -> String, WithError CompiledFormatString)
compileFromEscape String
s)

-- --------------------------------------------------------------------------
-- The escape functions
-- --------------------------------------------------------------------------

mkEscapeFunction :: (Char -> String) -> (String -> String)
mkEscapeFunction :: (Char -> String) -> String -> String
mkEscapeFunction Char -> String
chEscape String
str =
   [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
chEscape String
str)

bashEscape :: String -> String
bashEscape :: String -> String
bashEscape = (Char -> String) -> String -> String
mkEscapeFunction Char -> String
chbashEscape

chbashEscape :: Char -> String
chbashEscape :: Char -> String
chbashEscape Char
ch =
   case Char
ch of
      Char
'\\' -> String
"\\\\"
      Char
'\"' -> String
"\\\""
      Char
'$' -> String
"\\$"
      Char
'`' -> String
"\\`"
      Char
_ -> [Char
ch]

emacsEscape :: String -> String
emacsEscape :: String -> String
emacsEscape = (Char -> String) -> String -> String
mkEscapeFunction Char -> String
chEmacsEscape

chEmacsEscape :: Char -> String
chEmacsEscape :: Char -> String
chEmacsEscape Char
ch =
   case Char
ch of
      Char
'\n' -> String
"\\n"
      Char
'\t' -> String
"\\t"
      Char
'\r' -> String
"\\r"
      Char
'\f' -> String
"\\f"
      Char
'\b' -> String
"\\b"
      Char
'\\' -> String
"\\\\"
      Char
'\"' -> String
"\\\""
      Char
ch -> if Char -> Bool
isPrint Char
ch then [Char
ch] else String
"\\"String -> String -> String
forall a. [a] -> [a] -> [a]
++Char -> String
to3Oct Char
ch
   where
      -- Converts to octal representation padded to 3 digits.
      to3Oct :: Char -> String
      to3Oct :: Char -> String
to3Oct Char
ch =
         let
            chOct :: String
chOct = Char -> String
toOctal Char
ch
         in
            case String
chOct of
               String
"" -> String
"000"
               [Char
_] -> String
"00"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
chOct
               [Char
_,Char
_] -> String
"0" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chOct
               [Char
_,Char
_,Char
_] -> String
chOct
               String
_ -> String -> String
forall a. HasCallStack => String -> a
error
                  String
"Character with enormous character code can't be emacs-escaped"


-- | Converts character to representation.
toOctal :: Char -> String
toOctal :: Char -> String
toOctal Char
ch =
   -- We can't use Numeric.showOpt because GHC5.02.1 doesn't
   -- implement it!!!
   let
      toOct :: Int -> String
      toOct :: Int -> String
toOct Int
i =
         let
            (Int
q,Int
r) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
i Int
8
            e :: String
e = [Int -> Char
intToDigit Int
r]
         in
            if Int
qInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then String
e else Int -> String
toOct Int
qString -> String -> String
forall a. [a] -> [a] -> [a]
++String
e
   in
      Int -> String
toOct (Char -> Int
ord Char
ch)

-- --------------------------------------------------------------------------
-- runFormatString
-- --------------------------------------------------------------------------

runFormatString :: CompiledFormatString -> (Char -> Maybe String)
   -> WithError String
runFormatString :: CompiledFormatString -> (Char -> Maybe String) -> WithError String
runFormatString (CompiledFormatString [FormatItem]
l) Char -> Maybe String
lookup =
   let
      withErrors :: [WithError String]
withErrors =
         (FormatItem -> WithError String)
-> [FormatItem] -> [WithError String]
forall a b. (a -> b) -> [a] -> [b]
map
           (\ FormatItem
formatItem -> case FormatItem
formatItem of
              Unescaped String
str -> String -> WithError String
forall a. a -> WithError a
hasValue String
str
              Escaped String -> String
transformer Char
'%' -> String -> WithError String
forall a. a -> WithError a
hasValue String
"%"
              Escaped String -> String
transformer Char
ch -> case Char -> Maybe String
lookup Char
ch of
                 Maybe String
Nothing -> String -> WithError String
forall a. String -> WithError a
hasError (String
"%"String -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
ch]String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" not defined")
                 Just String
str -> String -> WithError String
forall a. a -> WithError a
hasValue (String -> String
transformer String
str)
              )
           [FormatItem]
l
      appendWithError :: WithError [a] -> WithError [a] -> WithError [a]
appendWithError WithError [a]
we1 WithError [a]
we2 = (([a], [a]) -> [a]) -> WithError ([a], [a]) -> WithError [a]
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError (([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++))
         (WithError [a] -> WithError [a] -> WithError ([a], [a])
forall a b. WithError a -> WithError b -> WithError (a, b)
pairWithError WithError [a]
we1 WithError [a]
we2)
   in
      (WithError String -> WithError String -> WithError String)
-> WithError String -> [WithError String] -> WithError String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr WithError String -> WithError String -> WithError String
forall a. WithError [a] -> WithError [a] -> WithError [a]
appendWithError (String -> WithError String
forall a. a -> WithError a
hasValue String
"") [WithError String]
withErrors


-- --------------------------------------------------------------------------
-- doFormatString
-- --------------------------------------------------------------------------

  -- doFormatString does everything at once, throwing an error if necessary.
doFormatString :: String -> (Char -> Maybe String) -> String
doFormatString :: String -> (Char -> Maybe String) -> String
doFormatString String
format Char -> Maybe String
lookup =
   let
      we1 :: WithError CompiledFormatString
we1 = String -> WithError CompiledFormatString
compileFormatString String
format
      we2 :: WithError String
we2 = (CompiledFormatString -> WithError String)
-> WithError CompiledFormatString -> WithError String
forall a b. (a -> WithError b) -> WithError a -> WithError b
mapWithError'
         (\ CompiledFormatString
compiled -> CompiledFormatString -> (Char -> Maybe String) -> WithError String
runFormatString CompiledFormatString
compiled Char -> Maybe String
lookup)
         WithError CompiledFormatString
we1
   in
      WithError String -> String
forall a. WithError a -> a
coerceWithError WithError String
we2