{-
    System.Installer : Installer wrapper for Haskell applications
    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
-}

{-# LANGUAGE TemplateHaskell #-}

module System.Installer.TH
    (makeInstallFuncCase,
     makeDataDecls,
     makeInstallFunc,
     makeImportDecl
    )
where

import System.FilePath
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Installer.Foreign

makeInstallFuncCase :: String -> (String, FilePath) -> Q Clause
makeInstallFuncCase funcName (clauseName, filepath)
    = result
    where
      result = clause [conP dataName []]
               (normalB [| writeFileData $ptr $len filename |]) []
      filename = takeFileName filepath
      dataName = mkName $ "Installer_" ++ fullName
      fullName = funcName ++ "_" ++ clauseName
      ptr = varE $ mkName ("installer_" ++ fullName)
      len = varE $ mkName ("installer_" ++ fullName ++ "_length")

makeInstallFunc :: String -> [Q Clause] -> Q [Dec]
makeInstallFunc funcName clauses
    = do { func <- funD name clauses
         ; funcSig <- sigD name (appT
                                 (appT arrowT (conT dataDeclName))
                                 (appT
                                  (appT arrowT (conT fpName))
                                  (appT (conT ioName) (conT tupName))))
         ; return [funcSig, func]
         }
    where
      name = mkName funcName
      dataDeclName = mkName $ "Installer_" ++ funcName
      fpName = mkName "FilePath"
      ioName = mkName "IO"
      tupName = mkName "()"

makeDataDecls :: String -> [(String, FilePath)] -> Q [Dec]
makeDataDecls base names
    = do { dataDecl' <- dataDecl
         ; instanceDecl' <- instanceDecl
         ; return [dataDecl', instanceDecl']
         }
    where
      dataDecl = dataD (cxt []) dataDeclName []
                 constructors $ map mkName ["Eq", "Ord", "Enum"]
      instanceDecl = instanceD (cxt []) (appT (conT (mkName "Show"))
                                         (conT dataDeclName))
                     [showFuncs]
      showFuncs = funD (mkName "show") $ map makeShowFunc names
      dataDeclName = mkName $ "Installer_" ++ base
      constructors = map makeDataCons names
      makeDataCons :: (String, FilePath) -> Q Con
      makeDataCons (name, _)
          = normalC (mkName $ "Installer_" ++ base ++ "_" ++ name) []
      makeShowFunc :: (String, FilePath) -> Q Clause
      makeShowFunc (name, _)
          = clause [conP dataName []] (normalB . litE . stringL $ name) []
          where
            dataName = mkName $ "Installer_" ++ base ++ "_" ++ name

makeImportDecl :: String -> (String, FilePath, FilePath) -> Q [Dec]
makeImportDecl funcName (clauseName, _, tmpPathCHeader)
    = makeImportDecl' ("installer_" ++ funcName ++ "_" ++ clauseName)
      tmpPathCHeader

makeImportDecl' :: String -> FilePath -> Q [Dec]
makeImportDecl' prefix headerFile
    = return [fileDataImport, fileLengthImport]
    where
      fileLengthImport = ForeignD
                         (ImportF CCall Safe
                          ("static " ++ headerFile ++ " " ++ prefix ++ "_length")
                          (mkName $ prefix ++ "_length")
                          (ConT (mkName "CInt"))
                         )
      fileDataImport = ForeignD
                       (ImportF CCall Safe
                        ("static " ++ headerFile ++ " " ++ prefix)
                        (mkName $ prefix)
                        (AppT (ConT (mkName "Ptr"))
                         (ConT (mkName "CUChar"))
                        )
                       )