tree and format

[cleanm.git] / format.icl

diff --git a/format.icl b/format.icl
new file mode 100644 (file)
index 0000000..506d520
--- /dev/null
+++ b/format.icl
@@ -0,0 +1,51 @@
+implementation module format
+
+import StdEnv
+
+import Data.Func
+import Data.Either
+import Data.Error
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Data.GenEq
+import Control.Applicative
+import Control.Monad
+import Text => qualified join
+import Text.Parsers.Simple.ParserCombinators
+
+:: FormatString :== [Format]
+:: Format
+       = FMTLiteral String
+       | FMTApply FormatFun [Format]
+
+:: FormatFun
+       = FFTag
+
+derive gEq Format, FormatFun
+instance == FormatString where == x y = x === y
+
+format :: [(String, String)] FormatString -> MaybeErrorString String
+format tags f = concat <$> mapM fmt f
+where
+       fmt :: Format -> MaybeErrorString String
+       fmt (FMTLiteral s) = pure s
+       fmt (FMTApply fun args) = case (fun, args) of
+               (FFTag, [tag,alt])
+                       = flip fromMaybe o flip lookup tags <$> fmt tag <*> fmt alt
+               (FFTag, _) = Error "`tag` must have exactly two arguments"
+               _ = Error "Unimplemented function"
+
+parseFormat :: [Char] -> MaybeErrorString FormatString
+parseFormat s = either (Error o concat) Ok (parse (some pFormat) s)
+
+pFormat :: Parser Char Format
+pFormat
+       =   FMTApply <$ pToken '$' <*> pFormatFun <* pToken '{' <*> pSepBy pFormat pComma <* pToken '}'
+       <|> FMTLiteral <$> toString <$> some (
+                    pToken '\\' *> pSatisfy (\x->isMember x ['${},'])
+               <|> pSatisfy (\x->not (isMember x ['$[],'])))
+       
+
+pFormatFun :: Parser Char FormatFun
+pFormatFun = FFTag <$ pList (map pToken ['tag'])