format.icl

   1 implementation module format
   2
   3 import StdEnv
   4
   5 import Data.Func
   6 import Data.Either
   7 import Data.Error
   8 import Data.Functor
   9 import Data.List
  10 import Data.Maybe
  11 import Data.GenEq
  12 import Control.Applicative
  13 import Control.Monad
  14 import Text => qualified join
  15 import Text.Parsers.Simple.ParserCombinators
  16
  17 :: FormatString :== [Format]
  18 :: Format
  19         = FMTLiteral String
  20         | FMTApply FormatFun [Format]
  21
  22 :: FormatFun
  23         = FFTag
  24
  25 derive gEq Format, FormatFun
  26 instance == FormatString where == x y = x === y
  27
  28 format :: [(String, String)] FormatString -> MaybeErrorString String
  29 format tags f = concat <$> mapM fmt f
  30 where
  31         fmt :: Format -> MaybeErrorString String
  32         fmt (FMTLiteral s) = pure s
  33         fmt (FMTApply fun args) = case (fun, args) of
  34                 (FFTag, [tag,alt])
  35                         = flip fromMaybe o flip lookup tags <$> fmt tag <*> fmt alt
  36                 (FFTag, _) = Error "`tag` must have exactly two arguments"
  37                 _ = Error "Unimplemented function"
  38
  39 parseFormat :: [Char] -> MaybeErrorString FormatString
  40 parseFormat s = either (Error o concat) Ok (parse (some pFormat) s)
  41
  42 pFormat :: Parser Char Format
  43 pFormat
  44         =   FMTApply <$ pToken '$' <*> pFormatFun <* pToken '{' <*> pSepBy pFormat pComma <* pToken '}'
  45         <|> FMTLiteral <$> toString <$> some (
  46                      pToken '\\' *> pSatisfy (\x->isMember x ['${},'])
  47                 <|> pSatisfy (\x->not (isMember x ['$[],'])))
  48
  49
  50 pFormatFun :: Parser Char FormatFun
  51 pFormatFun = FFTag <$ pList (map pToken ['tag'])