-- | 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 str =
   case splitToDollar str of
      Nothing -> hasValue (prependLiteral str (CompiledFormatString []))
      Just (s1,s2) ->
         mapWithError'
            (\ (ch,transformer,withError) ->
               mapWithError
                  (\ (CompiledFormatString l) ->
                     prependLiteral s1
                        (CompiledFormatString ((Escaped transformer ch):l))
                     )
                  withError
               )
            (compileFromEscape s2)

-- | Return portion up to (not including) first %, and portion after it.
splitToDollar :: String -> Maybe (String,String)
splitToDollar "" = Nothing
splitToDollar ('%':rest) = Just ("",rest)
splitToDollar (c:rest) = fmap (\ (s1,s2) -> (c:s1,s2)) (splitToDollar rest)

prependLiteral :: String -> CompiledFormatString -> CompiledFormatString
prependLiteral "" compiledFormatString = compiledFormatString
prependLiteral s (CompiledFormatString l) =
   CompiledFormatString (Unescaped s:l)

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

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

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

mkEscapeFunction :: (Char -> String) -> (String -> String)
mkEscapeFunction chEscape str =
   concat (map chEscape str)

bashEscape :: String -> String
bashEscape = mkEscapeFunction chbashEscape

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

emacsEscape :: String -> String
emacsEscape = mkEscapeFunction chEmacsEscape

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


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

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

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


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

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