{-# LANGUAGE TemplateHaskell, TupleSections, PackageImports #-}

module File.Binary.Quote (Field(..), Binary(..), binary) where

import Language.Haskell.TH (
	Q, DecsQ, ClauseQ, ExpQ, Dec, Exp(..), Name, FieldExp,
	dataD, recC, varStrictType, strictType, notStrict,
	instanceD, funD, clause, normalB, valD, tySynInstD, cxt,
	conT, appT, sigE, varP, tupP, letE, condE, recConE, tupE, listE,
	appE, appsE, infixApp, varE, litE, newName, integerL, stringL)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Data.Monoid (mconcat)
import Control.Monad (zipWithM)
import "monads-tf" Control.Monad.State (StateT, runStateT, get, put, lift)
import "monads-tf" Control.Monad.Writer (WriterT, runWriterT, tell)
import Control.Applicative ((<$>), (<*>))
import qualified Data.ByteString.Lazy.Char8 as BSLC (ByteString, pack)

import File.Binary.Parse (
	parse, BinaryStructure, bsName, bsDerive, bsArgName, bsArgType, bsItem,
	BSItem, argOf, valueOf, Value(..), variables, expression)
import File.Binary.Classes (Field(..), Binary(..))

--------------------------------------------------------------------------------

binary :: QuasiQuoter
binary = QuasiQuoter {
	quoteExp = undefined, quotePat = undefined, quoteType = undefined,
	quoteDec = top . parse
 }

top :: BinaryStructure -> DecsQ
top bs = let c = bsName bs in (\d i -> [d, i])
	<$> dataD (cxt []) c [] [recC c $
		map (varStrictType <$> fst <*> strictType notStrict . snd) $
			variables $ bsItem bs] (bsDerive bs)
	<*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [
		tySynInstD ''FieldArgument [conT c] $ bsArgType bs,
		funD 'fromBinary $ (: []) $ reading c (bsArgName bs) (bsItem bs),
		funD 'toBinary $ (: []) $ writing (bsArgName bs) (bsItem bs)
	 ]

reading :: Name -> String -> [BSItem] -> ClauseQ
reading con argn items = do
	arg <- newName "_arg"
	bin <- newName "bin"
	flip (clause [varP arg, varP bin]) [] $
		normalB $ letRec $ binToDat con items (varE bin) $ \ret ->
			expression ret (varE arg) argn . argOf

letRec :: (ExpQ -> ExpQ) -> ExpQ
letRec e = do
	(ret, rest) <- (,) <$> newName "ret" <*> newName "rest"
	letE [valD (tupP [varP ret, varP rest]) (normalB $ e $ varE ret) []] $
		tupE [varE ret, varE rest]

binToDat :: Name -> [BSItem] -> ExpQ -> (ExpQ -> BSItem -> ExpQ) -> ExpQ -> ExpQ
binToDat con items bin size ret = do
	((binds, rest), rts) <- runWriterT $ (`runStateT` bin) $
		(zipWithM binToField <$> map (size ret) <*> map valueOf) items
	letE (return <$> binds) $ tupE $ (: [rest]) $ recConE con $ return <$> rts

type FieldMonad = StateT ExpQ (WriterT [FieldExp] Q)

liftQ :: Q a -> FieldMonad a
liftQ = lift . lift

liftW :: WriterT [FieldExp] Q a -> FieldMonad a
liftW = lift

binToField :: ExpQ -> Value -> FieldMonad Dec
binToField size (Constant val) = do
	bin <- get
	[rv, rest, bin'] <- liftQ $ mapM newName ["rv", "rst", "bin'"]
	put $ varE bin'
	let lit = either
		((`sigE` conT ''Integer) . litE . integerL)
		((`sigE` conT ''BSLC.ByteString) .
			appE (varE 'BSLC.pack) . litE . stringL) val
	liftQ $ flip (valD $ varP bin') [] $ normalB $
		letE [flip (valD $ tupP [varP rv, varP rest]) [] $ normalB $
			appsE [varE 'fromBinary, size, bin]] $
		condE (infixApp (varE rv) (varE '(==)) lit) (varE rest)
			[e| error "bad value" |]
binToField size (Variable var) = do
	bin <- get
	[bin', tmp] <- liftQ $ mapM newName ["bin'", "tmp"]
	put $ varE bin'
	liftW $ tell [(var, VarE tmp)]
	liftQ $ valD (tupP [varP tmp, varP bin'])
		(normalB $ appsE [varE 'fromBinary, size, bin]) []

writing :: String -> [BSItem] -> ClauseQ
writing argn items = do
	arg <- newName "_arg"
	dat <- newName "_dat"
	flip (clause [varP arg, varP dat]) [] $ normalB $
		appE (varE 'mconcat) $ listE $ (<$> items) $ fieldToBin dat
			<$> expression (varE dat) (varE arg) argn . argOf
			<*> valueOf

fieldToBin :: Name -> ExpQ -> Value -> ExpQ
fieldToBin _ size (Constant val) =  varE 'toBinary `appE` size `appE` either
	((`sigE` conT ''Integer) . litE . integerL)
	((`sigE` conT ''BSLC.ByteString) . appE (varE 'BSLC.pack) . litE . stringL)
	val
fieldToBin dat size (Variable val) =
	varE 'toBinary `appE` size `appE` (varE val `appE` varE dat)