module Ehs(ehs, pehs, Embeddable(..), EmbeddableIO) where
import Control.Applicative (Applicative(..))
import Control.Monad hiding (forM, forM_)
import Control.Monad.IO.Class(liftIO)
import Control.Monad.Trans.Writer.Strict
import Data.Foldable(forM_)
import Data.Monoid
import Ehs.Parser
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Parsec(parse)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
newtype Mon m a = Mon { getMon :: m a }
instance (Monoid w, Monad m) => Monoid (Mon m w) where
mempty = Mon $ return mempty
mappend (Mon f) (Mon g) = Mon $ liftM2 mappend f g
ehs :: QuasiQuoter
ehs = QuasiQuoter
{ quoteExp = \str -> case parse parseEhses "ehs" str of
Right result -> buildExp result
Left err -> fail $ "parse error: " ++ show err
, quotePat = undefined
, quoteType = undefined
, quoteDec = \str -> case parse parseEhses "ehs" str of
Right result -> buildMain result
Left err -> fail $ "parse error: " ++ show err
}
buildExp :: [Ehs String] -> ExpQ
buildExp es = [| execWriterT $(buildDo es) >>= getMon |]
buildDo :: [Ehs String] -> ExpQ
buildDo es = doE $ map buildDoStmt $ es ++ [Plain ""]
buildDoStmt :: Ehs String -> StmtQ
buildDoStmt (Plain s) = noBindS [| tell (Mon (return s :: IO String)) |]
buildDoStmt (Embed exp) = noBindS [| tell (Mon (embedIO $(return exp))) |]
buildDoStmt (Bind pat exp) = bindS (return pat) [| liftIO $(return exp) |]
buildDoStmt (Let decs) = letS $ map return decs
buildDoStmt (For pat exp es) = noBindS [| forM_ $(return exp) $ \($(return pat)) -> $(buildDo es) |]
buildDoStmt (If clauses) = do
elseClause <- do
t <- [| otherwise |]
return (t, [Plain ""])
noBindS $ multiIfE $ flip map (clauses ++ [elseClause]) $ \(exp, es) -> do
innerIf <- buildDo es
cond <- normalG $ return exp
return (cond, innerIf)
buildDoStmt _ = error "Illegal Term."
buildMain :: [Ehs String] -> Q [Dec]
buildMain es = do
main' <- funD (mkName "main") [clause [] doBody []]
return [main']
where
doBody = normalB $ doE $ [noBindS [| $(buildExp es) >>= putStr |]]
pehs :: QuasiQuoter
pehs = QuasiQuoter
{ quoteExp = \str -> case parse parseEhses "pehs" str of
Right result -> buildExpPure result
Left err -> fail $ "parse error: " ++ show err
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
newtype Id a = Id { runId :: a }
deriving (Functor)
instance Applicative Id where
pure = Id
Id f <*> Id x = Id (f x)
instance Monad Id where
return = Id
Id x >>= f = f x
buildExpPure :: [Ehs String] -> ExpQ
buildExpPure es = [| runId (execWriterT $(buildDoPure es) >>= getMon) |]
buildDoPure :: [Ehs String] -> ExpQ
buildDoPure es = doE $ map buildDoStmtPure $ es ++ [Plain ""]
buildDoStmtPure :: Ehs String -> StmtQ
buildDoStmtPure (Plain s) = noBindS [| tell (Mon (Id s :: Id String)) |]
buildDoStmtPure (Embed exp) = noBindS [| tell (Mon (Id (embed $(return exp)))) |]
buildDoStmtPure (Bind pat exp) = bindS (return pat) [| Id $(return exp) |]
buildDoStmtPure (Let decs) = letS $ map return decs
buildDoStmtPure (For pat exp es) = noBindS [| forM_ $(return exp) $ \($(return pat)) -> $(buildDoPure es) |]
buildDoStmtPure (If clauses) = do
elseClause <- do
t <- [| otherwise |]
return (t, [Plain ""])
noBindS $ multiIfE $ flip map (clauses ++ [elseClause]) $ \(exp, es) -> do
innerIf <- buildDoPure es
cond <- normalG $ return exp
return (cond, innerIf)
buildDoStmtPure _ = error "Illegal Term."
class Embeddable a where
embed :: a -> String
instance Embeddable String where
embed = id
instance Embeddable BS.ByteString where
embed = embed . BS.unpack
instance Embeddable BL.ByteString where
embed = embed . BL.unpack
instance Embeddable TS.Text where
embed = embed . TS.unpack
instance Embeddable TL.Text where
embed = embed . TL.unpack
instance Show a => Embeddable a where
embed = show
class EmbeddableIO a where
embedIO :: a -> IO String
instance Embeddable a => EmbeddableIO a where
embedIO = return . embed
instance Embeddable a => EmbeddableIO (IO a) where
embedIO = (>>=embedIO)