gistfile1.hs

{-# 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)