{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Ehs.Internal where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.Meta
import Control.Applicative ((<$>),(<$))
import Control.Arrow((***))
import Control.Monad
import Text.Parsec.String
import Text.Parsec.Prim
import Text.Parsec.Char
import Text.Parsec.Combinator
import qualified Data.DList as D

ehs :: QuasiQuoter
ehs = QuasiQuoter
  { quoteExp = \str -> case parse parseEhs "ehs" str of
      Right result -> buildExp result 
      Left  err    -> fail $ "parse error: " ++ show err
  , quotePat  = undefined
  , quoteType = undefined
  , quoteDec  = \str -> case parse parseEhs "ehs" str of
      Right result -> buildMain result 
      Left  err    -> fail $ "parse error: " ++ show err
  }

buildExp :: [Ehs] -> ExpQ
buildExp es = do
  (vars, stmts) <- (D.toList *** D.toList) <$> foldM buildStmt (D.empty, D.empty) es
  let lastReturn = [noBindS (appE (varE 'return) (appE (varE 'concat) (listE vars)))]
  doE $ stmts ++ lastReturn
  where
    buildStmt (vars, stmts) e = case e of 
      Plain s -> strBind [| embed s |]
      Embed exp -> strBind [| embed $(return exp) |]
      Bind pat exp -> do
        stmt <- bindS (return pat) (return exp)
        return (vars, D.snoc stmts (return stmt))
      where
        strBind expq = do
          name <- newName "tmp"
          stmt <- bindS (varP name) expq
          return (D.snoc vars (varE name), D.snoc stmts (return stmt))
  
buildMain :: [Ehs] -> Q [Dec]
buildMain es = do
  main' <- funD (mkName "main") [clause [] doBody []]
  return [main']
  where
    doBody = normalB $ doE $ map buildStmt es
    buildStmt (Plain s)   = noBindS [| putStr s |]
    buildStmt (Embed exp) = noBindS [| embed $(return exp) >>= putStr |]
    buildStmt (Bind pat exp) = bindS (return pat) (return exp)

class Embeddable a where
  embed :: a -> IO String

instance Embeddable String where
  embed = return

instance Show a => Embeddable a where
  embed = return . show

instance Embeddable (IO String) where
  embed = id

instance Show a => Embeddable (IO a) where
  embed = liftM show

data Ehs = 
    Plain String  -- foo
  | Embed Exp     -- <%= foo %>
  | Bind  Pat Exp -- <%  foo <- bar %>
  deriving (Show,Eq)

parseEhs :: Parser [Ehs]
parseEhs = (++ [Plain ""]) <$> many (parseEmbed <|> parseBind <|> parsePlain)

parseEmbed :: Parser Ehs
parseEmbed = do
  try $ string "<%="
  e <- manyTill anyChar $ try (string "%>")
  exp <- case parseExp e of
    Right exp -> return exp
    Left  err -> fail $ "<%= %>: " ++ err
  return $ Embed exp

parseBind :: Parser Ehs
parseBind = do
  try $ string "<%"
  p <- manyTill anyChar $ try (string "<-")
  e <- manyTill anyChar $ try (string "%>")
  pat <- case parsePat p of
    Right pat -> return pat
    Left  err -> fail $ "<% %>: " ++ err
  exp <- case parseExp e of
    Right exp -> return exp
    Left  err -> fail $ "<% %>: " ++ err
  optional newline
  return $ Bind pat exp

parsePlain :: Parser Ehs
parsePlain = liftM Plain $ many1Till anyChar $ lookAhead $ void (try (string "<%")) <|> eof

many1Till :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
many1Till p end = scan
  where
    scan = do
      x <- p
      xs <- ([] <$ end) <|> scan
      return $ x : xs