TH.hs

{-
    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)
where

import System.IO
import System.Directory
import System.FilePath
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

makeInstallFuncCase :: String -> String -> FilePath -> String -> Q Clause
makeInstallFuncCase funcName name filepath contents
    = result
    where
      result = clause [conP dataName []]
               (normalB [| writeFileData filename $contentsQ |]) []
      contentsQ = liftString contents
      dataName = mkName $ "Installer_" ++ funcName ++ "_" ++ name
      filename = takeFileName filepath

makeInstallFunc :: String -> [Q Clause] -> Q Dec
makeInstallFunc funcName clauses
    = funD (mkName funcName) clauses

writeFileData :: String -> String -> FilePath -> IO ()
writeFileData origName content path
    = do { isDir <- doesDirectoryExist path
         ; let path' = if isDir then combine path origName else path
         ; h <- openFile path' WriteMode
         ; hPutStr h content
         ; hClose h
         }

liftString :: String -> Q Exp
liftString = return . LitE . StringL

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