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
| Embed Exp
| Bind Pat Exp
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
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 (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