bamse-0.9.1: Bamse/PackageUtils.hs

--
-- (c) 2007, Galois, Inc.
--
-- Misc helper functions that come in handy when
-- defining installer modules.
--
module Bamse.PackageUtils where

import Bamse.Package

import Util.Path ( appendPath, toPlatformPath, fileSuffix )
import System.Path (isSeparator)

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

-- | convert (base) filename to 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 = toPlatformPath $ appendPath dir f
  -- sigh, Util.Path.appendPath inserts a forward slash, not
  -- the platform default one, so we need to normalize the path
  -- afterwards.

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

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

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

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


-- 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 ('\\':'>':xs) = let (as,bs) = getDefault xs in ('>':as,bs)
   getDefault ('>':xs) = ([],xs)
   getDefault (x:xs) = let (as,bs) = getDefault xs 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 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 (\ (nm,val) -> RegEntry "OnInstall" proj_path
   			       (CreateName (Just nm) val))
       values
 where
   proj_path = "Software\\Haskell\\Projects\\"++nm

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 (\ (nm,val) -> RegEntry "OnInstall" ver_path (CreateName (Just nm) val))
       values
 where
   impl_path = "Software\\Haskell\\"++nm
   ver_path = "Software\\Haskell\\"++nm ++ '\\':version

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"