-----------------------------------------------------------
-- |
-- Module      : Ehs
-- Copyright   : (C) 2014-2015, Yu Fukuzawa
-- License     : MIT
-- Maintainer  : minpou.primer@email.com
-- Stability   : experimental
-- Portability : portable
--
-- See also <http://github.com/minpou/ehs/blob/master/README.md>
-----------------------------------------------------------

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
  {-# INLINE mempty #-}
  mappend (Mon f) (Mon g) = Mon $ liftM2 mappend f g
  {-# INLINE mappend #-}

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 |]]

{- pure version -}

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
  {-# INLINE return #-}
  Id x >>= f = f x
  {-# INLINE (>>=) #-}

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)