mwotton · October 4, 2014 01:17 · Oct 4, 2014
diff --git a/gistfile1.hs b/gistfile1.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE InstanceSigs, OverloadedStrings #-}
+
+module Text.Parser.Selmer where
+
+import           Control.Applicative
+import           Data.Char           (isAlpha)
+import           Data.Map.Lazy       (Map)
+import qualified Data.Map.Lazy       as M
+import           Data.Maybe          (fromMaybe)
+import           Data.Monoid
+import           Data.Text           (Text)
+import qualified Data.Text           as Text
+import           Prelude             hiding (getChar, takeWhile)
+
+{- mini parser impl -}
+newtype Parser a = P (String -> [ (a, String) ])
+
+returnP a = P (\x -> [(a,x)])
+
+instance Monad Parser where
+  (P p1) >>= other = P $ \input -> concat [ p2 rest | (next,rest) <- p1 input, let P p2 = other next]
+  return = returnP
+  fail _     = P $ \_ ->  []
+
+instance Applicative Parser where
+  pure = returnP
+  d <*> e = do
+    b <- d
+    a <- e
+    return (b a)
+
+instance Functor Parser where
+  f `fmap` (P p) =  P (map (\(x,s) -> (f x,s)) . p)
+
+instance Alternative Parser where
+  empty = P (const [])
+  (P a) <|> (P b) = P (\x -> a x ++ b x)
+
+string = mapM char
+char = satisfy . (==)
+
+getChar :: Parser Char
+getChar = P $ \cs -> case cs of
+  (x:xs) -> [ (x, xs) ]
+  []     -> []
+
+satisfy :: (Char -> Bool) -> Parser Char
+satisfy p = do
+  c <- getChar
+  if p c then return c else fail "Did not satisfy boolean predicate"
+
+takeWhile1 pred = (:) <$> satisfy pred <*> takeWhile pred
+takeWhile pred = many $ satisfy pred
+
+parseOnly :: Parser a -> String -> Either String a
+parseOnly (P p) s = case p s of
+  []  -> Left "No parse"
+  ((x,_):_) ->  Right x
+{- end mini parser impl -}
+
+newtype Var = Var Text deriving Show
+
+data Node = VarNode Var | TextNode Text deriving Show
+type Context = (Map Text Text)
+
+parseDoubleCurly :: Parser a -> Parser a
+parseDoubleCurly p = string "{{" *> p <* string "}}"
+
+parseVar :: Parser Var
+parseVar = parseDoubleCurly $ (Var . Text.pack <$> takeWhile1 isAlpha)
+
+parseNode :: Parser Node
+parseNode = TextNode . Text.pack <$> takeWhile1 (/= '{')
+
+parseStream :: Parser [Node]
+parseStream = many $ (parseNode <|> (VarNode <$> parseVar))
+
+renderNode :: Context -> Node -> Text
+renderNode ctx (VarNode (Var name)) = fromMaybe "" (M.lookup name ctx)
+renderNode ctx (TextNode txt) = txt
+
+render :: Context -> [Node] -> Text
+render context nodes = foldr
+       (\node extant ->
+         mappend (renderNode context node) extant)
+         "" nodes
+
+main = do
+  let context  = M.fromList [("blah", "1")]
+  let parser   = parseOnly parseStream
+  let template = "{{blah}} woot"
+  let maybeRendered = (render context <$> (parser template))
+  putStrLn (show maybeRendered)