bamse-0.9.4: Bamse/PackageUtils.hs

--------------------------------------------------------------------
-- |
-- Module      : Bamse.PackageUtils
-- Description : Helper functions for installer template modules.
-- Copyright   : (c) Sigbjorn Finne, 2004-2009
-- License     : BSD3
--
-- Maintainer  : Sigbjorn Finne <sof@forkIO.com>
-- Stability   : provisional
-- Portability : portable
--
-- Misc helper functions that come in handy when defining installer modules.
-- 
--------------------------------------------------------------------
module Bamse.PackageUtils where

import Bamse.Package

import System.FilePath

import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
import System.Environment
import Debug.Trace ( trace )

import Text.Regex
import Data.Char ( isSpace )
import Data.Maybe
import Data.List

-- | @toMsiFileName fp@ converts a (base) filename to an MSI output
-- filename, appending the .msi suffix + doing away with 
-- troublesome characters.
toMsiFileName :: FilePath -> FilePath
toMsiFileName f = map dotToDash f ++ ".msi"
 
dotToDash :: Char -> Char
dotToDash '.' = '-'
dotToDash x   = x

lFile :: FilePath -> FilePath -> FilePath
lFile dir f = normalise (dir </> f)

-- classifying files according to their extension/suffix:
isHiFile :: FilePath -> Bool
isHiFile fn = 
  case takeExtension fn of
    ".hi" -> True
    '.':_:'_':'h':'i':[] -> True
    _ -> False

isDocFile :: FilePath -> Bool
isDocFile fn = takeExtension fn `elem` [".html", ".pdf", ".dvi", ".doc", ".ps"]

isHeaderFile :: FilePath -> Bool
isHeaderFile fn = takeExtension fn `elem` [".h"]

dropDirPrefix :: FilePath -> FilePath -> FilePath
dropDirPrefix [] f = dropWhile isPathSep f
dropDirPrefix _ [] = []
dropDirPrefix (x:xs) (y:ys)
  | x == y    = dropDirPrefix xs ys
  | otherwise = dropWhile isPathSep (y:ys)
 where

isPathSep :: Char -> Bool
isPathSep c = isPathSeparator c || c == '/'

-- to support build-time definitions in strings (via $<FOO>)
addEnvVar :: String -> String -> IO ()
addEnvVar var val = do
  ls <- readIORef env_list
  writeIORef env_list ((var,val):ls)

env_list :: IORef [(String,String)]
env_list = unsafePerformIO (newIORef [])

env :: String -> String
env s = 
  case mbEnv s of
    Nothing -> ""
    Just v  -> v

expandString :: String -> String
expandString [] = []
expandString ('$':'<':xs) = 
      case break isTerm xs of
        (_as,[]) -> '$' : '<' : expandString xs
	(var,y:ys) -> 
	    case mbEnv var of
	      Nothing  -> 
	        case y of
		  ':' -> 
		    case getDefault ys of
		      (as,bs) -> as ++ expandString bs
		  _ -> '$':'<' : expandString xs
	      Just val -> 
	        trace ("Expanding variable " ++ show var ++ " to " ++ show val) $
		  val ++ 
		   case y of
		     ':' -> expandString (snd $ getDefault ys)
		     _ -> expandString ys
  where
   isTerm '>' = True
   isTerm ':' = True
   isTerm _   = False
   
   getDefault [] = ([],[])
   getDefault ('\\':'>':cs) = let (as,bs) = getDefault cs in ('>':as,bs)
   getDefault ('>':ds) = ([],ds)
   getDefault (x:cs) = let (as,bs) = getDefault cs in (x:as,bs)
expandString (x:xs) = x : expandString xs

mbEnv :: String -> Maybe String
mbEnv s = unsafePerformIO $
   catch (fmap Just (getEnv s))
         (\ _ -> do
	   ls <- readIORef env_list
	   return (lookup s ls))

haskellProject :: String -> [(String,String)] -> [RegEntry]
haskellProject nm values
 = RegEntry "OnInstall" "Software" 	              (CreateKey False) :
   RegEntry "OnInstall" "Software\\Haskell" 	      (CreateKey False) :
   RegEntry "OnInstall" "Software\\Haskell\\Projects" (CreateKey False) :
   RegEntry "OnInstall" proj_path                     (CreateKey True)  :
   map (\ (k,val) -> RegEntry "OnInstall" proj_path (CreateName (Just k) val))
       values
 where
   proj_path = "Software\\Haskell\\Projects\\"++nm

haskellImpl :: String -> String -> [(String,String)] -> [RegEntry]
haskellImpl nm version values
 = RegEntry "OnInstall" "Software"          (CreateKey False) :
   RegEntry "OnInstall" "Software\\Haskell" (CreateKey False) :
   RegEntry "OnInstall" impl_path           (CreateKey False) :
   RegEntry "OnInstall" impl_path           (CreateName (Just "InstallDir") "[TARGETDIR]") :
   RegEntry "OnInstall" ver_path            (CreateKey True)  :
   map (\ (k,val) -> RegEntry "OnInstall" ver_path (CreateName (Just k) val))
       values
 where
   impl_path = "Software\\Haskell\\"++nm
   ver_path = "Software\\Haskell\\"++nm ++ '\\':version

hugsPath :: String -> (String, String)
hugsPath val = ("hugsPath", val)

haskellExtension :: FilePath -> FilePath -> FilePath -> String -> Extension
haskellExtension binary _topDir bamseDir ext 
  = ( "HaskellFile"
    , binary
    , lFile iconDir "hs2.exe"
    , ext
    )
 where
  iconDir = lFile bamseDir "icons"

getManifest :: [(String,String)] -> IO (String -> Maybe Bool)
getManifest opts = 
     case lookup "manifest" opts of
       Just fn -> catch (do { ls <- readFile fn ; return (tryMatch (mapMaybe toRegex $ lines ls))}) 
                        (\ _ -> return (const Nothing))
       Nothing -> return (const Nothing)
 where

   tryMatch [] _ = Nothing
   tryMatch ((flg,x):xs) f = 
      case matchRegex x f of
        Nothing -> tryMatch xs f
	Just{}  -> Just flg

   toRegex "" = Nothing
   toRegex ('#':_) = Nothing
   toRegex r
    | all isSpace r = Nothing
    | otherwise     = 
       -- a single leading '-' indicate that pattern is for exemptions.
      case trim r of
        ('-':xs) -> Just (False,mkRegex xs)
	xs -> Just (True,mkRegex xs)
    
   trim s = trimR (dropWhile isSpace s)
   
   trimR xs = maybe "" id $ foldr f Nothing xs
    where
     f x (Just acc) = Just (x:acc)
     f x Nothing
      | isSpace x = Nothing
      | otherwise = Just [x]

entryOfInterest :: InstallEnv -> (String -> Maybe Bool) -> FilePath -> Bool
entryOfInterest ienv matcher file
 | defaultJunk file = False
 | null file'       = True
 | otherwise        = 
    case maybe True id (matcher file') of
      flg 
       | traceIt   -> trace ((if flg then "including" else "excluding") ++ ": " ++ show (file',file)) flg
       | otherwise -> flg
 where
  file' 
   | topDir `isPrefixOf` file = canonicalize (drop (length topDir) file)
   | otherwise = file

  topDir = srcDir ienv 
  traceIt = isJust (lookup "debug" (userOpts ienv))

  canonicalize ('\\':xs) = canonicalize xs
  canonicalize xs = canon1 xs

  canon1 xs = map (\ x -> if x == '\\' then '/' else x) xs

  defaultJunk f = (last f == '~') ||  (takeFileName f == ".svn")