{-# LANGUAGE TemplateHaskell #-}

{-
    Text.HTML.Chunks : simple templates with static safety
    Copyright (C) 2007  Matthew Sackman

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Text.HTML.Chunks.TH
    (declsD,
     declsF
    )
    where

import qualified Text.HTML.Chunks.Parser as P
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Either
import Data.List

baseName :: String
baseName = "Chunk_"

declsD :: Either a [P.Chunk] -> Q [Dec]
declsD (Left _) = return []
declsD (Right chunks) = sequence dataDecls >>= return
    where
      dataDecls = map (\(P.Chunk n b) -> makeDataDecl n b) $ chunks

declsF :: Either a [P.Chunk] -> Q [Dec]
declsF (Left _) = return []
declsF (Right chunks) = sequence formatters >>= return
    where
      formatters = map (\(P.Chunk n b) -> (makeFormatter n b)) chunks

makeDataDecl :: String -> [P.Content] -> DecQ
makeDataDecl suffix content = dataDec
    where
      dataDec = dataD (cxt []) name [] [recC name fields] [showC]
      name = mkName (baseName ++ suffix)
      fields = map (\(P.Variable v) -> return (mkName $ suffix ++ "_" ++ v,
                                             NotStrict, ConT stringName))
               . nub . filter P.isVariable $ content
      stringName = mkName "String"
      showC = mkName "Show"

makeFormatter :: String -> [P.Content] -> DecQ
makeFormatter suffix content = instDec
    where
      instDec = instanceD (cxt []) (appT (conT chunkC) (conT name)) [func']
      name = mkName (baseName ++ suffix)
      (func, contentUsed) = makeFormatterB recE suffix content ([| "" |], False)
      func' = funD formatN [clause [recP] (normalB func) []]
      conName = mkName "content"
      recE = varE conName
      recP = varP conNameUsed
      conNameUsed = if contentUsed then conName else mkName "_"
      chunkC = mkName "Chunk"
      formatN = mkName $ "format"

makeFormatterB :: ExpQ -> String -> [P.Content] -> (ExpQ, Bool) -> (ExpQ, Bool)
makeFormatterB _ _ [] acc = acc
makeFormatterB p n ((P.Text t):c) (acc, contentUsed)
    = makeFormatterB p n c ([| $acc ++ $(lift t) |], contentUsed)
makeFormatterB p n ((P.Variable v):c) (acc, contentUsed)
    = makeFormatterB p n c ([| $acc ++ $application |], True)
    where
      fieldName = varE $ mkName $ n ++ "_" ++ v
      application = [| $fieldName $p |]