bamse-0.9.4: Bamse/DiaWriter.hs
--------------------------------------------------------------------
-- |
-- Module : Bamse.DiaWriter
-- Description : Converting a Dialog type into an MSI dialog.
-- Copyright : (c) Sigbjorn Finne, 2004-2009
-- License : BSD3
--
-- Maintainer : Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability : portable
--
-- Converting a Dialog type into an MSI dialog.
--
--------------------------------------------------------------------
module Bamse.DiaWriter where
--import Bamse.Dialog
import Bamse.MSITable
import Bamse.IMonad
import Bamse.Package
import Control.Monad
import Data.Int
import Data.Bits
import Data.Maybe
writeDialog :: PackageData -> Bool -> Dialog -> IM ()
writeDialog pkg hasLicense
(Dialog diaName cs conds evs
(hc,vc) (w,h) attrs
ttle first def cancel
afterDlg afterDlgCond props) = do
addRow (newDialog [ "Dialog" -=> Just (string diaName)
, "HCentering" -=> Just (int hc)
, "VCentering" -=> Just (int vc)
, "Width" -=> Just (int w)
, "Height" -=> Just (int h)
, "Attributes" -=> Just (int (flattenAttrib attrs))
, "Title" -=> Just (string ttle)
, "Control_First" -=> Just (string first)
, "Control_Default" -=> Just (string def)
, "Control_Cancel" -=> Just (string cancel)
])
mapM_ (addControlEvent diaName) evs
mapM_ (addControl diaName) cs
mapM_ (addControlCondition diaName) conds
-- have 'after dialog's Next button spawn this dialog..
let (afterDlg', afterDlgCond') =
case afterDlg of
"WelcomeDlg"
| hasLicense -> ("LicenseAgreementDlg", "IAgree = \"Yes\" AND ShowLicenseDlg = 1")
| otherwise -> (afterDlg, afterDlgCond)
"SetupKindDialog"
| hasLicense -> ("LicenseAgreementDlg", "IAgree = \"Yes\" AND ShowLicenseDlg = 1")
| isJust (p_cabalPackage pkg) ->
("CabalDialog", afterDlgCond)
| otherwise -> (afterDlg, afterDlgCond)
"CustomizeDlg" -> (afterDlg, afterDlgCond)
_ -> (afterDlg, afterDlgCond)
addRow (newControlEvent [ "Dialog_" -=> Just (string afterDlg') -- "WelcomeDlg")
, "Control_" -=> Just (string "Next")
, "Event" -=> Just (string "NewDialog")
, "Argument" -=> Just (string diaName)
, "Condition" -=> Just (string afterDlgCond') -- "NOT Installed")
, "Ordering" -=> Just (string "3")
])
-- and our Back button point to the 'after dialog'.
addRow (newControlEvent [ "Dialog_" -=> Just (string diaName)
, "Control_" -=> Just (string "Back")
, "Event" -=> Just (string "NewDialog")
, "Argument" -=> Just (string afterDlg)
, "Condition" -=> Just (string "1")
])
-- Our Next button will invoke the dialog that
-- used to follow (ditto for its Back button.)
let nextDlg
= case afterDlg of
"WelcomeDlg" ->
if diaName == "SetupKindDialog" && isJust (p_cabalPackage pkg)
then "CabalDialog"
else "SetupTypeDlg"
"SetupKindDialog" -> "SetupTypeDlg"
"CustomizeDlg" -> "VerifyReadyDlg"
_ -> error ("unknown/unsupported dialog: " ++ afterDlg)
addRow (newControlEvent ([ "Dialog_" -=> Just (string diaName)
, "Control_" -=> Just (string "Next")
, "Event" -=> Just (string "NewDialog")
, "Argument" -=> Just (string nextDlg)
, "Condition" -=> Just (string "1") -- "NOT Installed"
]))
-- ioToIM (print (nextDlg,diaName))
addRow (newControlEvent [ "Dialog_" -=> Just (string nextDlg) -- "SetupTypeDlg"
, "Control_" -=> Just (string "Back")
, "Event" -=> Just (string "NewDialog")
, "Argument" -=> Just (string diaName)
, "Condition" -=> Just (string afterDlgCond') -- "NOT Installed"
])
mapM_
(\ (p,v) -> addRow (newProperty [ "Property" -=> Just (string p)
, "Value" -=> Just (string v)
]))
props
setupGhcPackage :: GhcPackage -> IM ()
setupGhcPackage pkg = do
let pkg_file = fromMaybe "package.pkg" (ghc_packageFile pkg)
mapM_ (\ act -> do
addRow (act [ "Action" -=> Just (string "INSTALLGHCPKG")
, "Condition" -=> Just (string ("NOT Installed AND RUNPKGMGR=1"))
, "Sequence" -=> Just (int 6601)
])
addRow (act [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")
, "Condition" -=> Just (string "REMOVE")
, "Sequence" -=> Just (int 6602)
]))
[ newAdminExecuteSequence
, newInstallExecuteSequence
]
addRow (newCustomAction
[ "Action" -=> Just (string "UNINSTALL_GHC_PKG")
-- ignore errors
, "Type" -=> Just (int (50+64))
, "Source" -=> Just (string "GHCPKGDIR")
, "Target" -=> Just (string ("-r " ++ ghc_packageName pkg))
])
let opts =
"-DTARGETDIR=\"[TARGETDIR]\\\"" ++
case ghc_pkgCmdLine pkg of
Nothing -> []
Just v -> ' ':v
addRow (newCustomAction
[ "Action" -=> Just (string "INSTALLGHCPKG")
, "Type" -=> Just (int 50)
, "Source" -=> Just (string "GHCPKGDIR")
, "Target" -=> Just (string ("-u -i \"[TARGETDIR]"++pkg_file++"\" " ++ opts))
])
setupCabalPackage :: CabalPackage -> IM ()
setupCabalPackage pkg = do
mapM_ (\ act -> do
addRow (act [ "Action" -=> Just (string "CONFIGCABAL")
, "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1"))
, "Sequence" -=> Just (int 6601)
])
addRow (act [ "Action" -=> Just (string "BUILDCABAL")
, "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1"))
, "Sequence" -=> Just (int 6602)
])
addRow (act [ "Action" -=> Just (string "INSTALLCABAL")
, "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL<>1 AND RUNPKGMGR=1"))
, "Sequence" -=> Just (int 6603)
])
addRow (act [ "Action" -=> Just (string "INSTALLCABAL2")
, "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1 AND RUNPKGMGR=1"))
, "Sequence" -=> Just (int 6603)
])
addRow (act [ "Action" -=> Just (string "UNINSTALL_CABAL")
, "Condition" -=> Just (string "REMOVE")
, "Sequence" -=> Just (int 6604)
]))
[ newAdminExecuteSequence
, newInstallExecuteSequence
]
let opts = ""
{-
"-DTARGETDIR=\"[TARGETDIR]\\\"" ++
case cabal_pkgCmdLine pkg of
Nothing -> []
Just v -> ' ':v
-}
{-
Performing Cabal operations:
* unable to invoke 'runghc' directly here (via a Type:50 custom action), as
we have to be in the target directory to perform the operation.
* provide a simple call wrapper instead that simply adjusts the CWD before
invoking 'runghc'. It needs to be named "custWrap.exe" and present in the
toplevel target directory. The source for it is in Wrapper.hs in the toplevel
of the Bamse tree.
-}
fKey <- findExeFile "custWrap.exe"
addRow (newCustomAction
[ "Action" -=> Just (string "INSTALLCABAL")
, "Type" -=> Just (int 18)
, "Source" -=> Just (string fKey) -- "GHCPKG")
, "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install " ++ opts))
])
addRow (newCustomAction
[ "Action" -=> Just (string "INSTALLCABAL2")
, "Type" -=> Just (int 18)
, "Source" -=> Just (string fKey) -- "GHCPKG")
, "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install --builddir=ldist" ++ opts))
])
addRow (newCustomAction
[ "Action" -=> Just (string "CONFIGCABAL")
, "Type" -=> Just (int 18)
, "Source" -=> Just (string fKey)
, "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup configure --builddir=ldist" ++ opts))
])
addRow (newCustomAction
[ "Action" -=> Just (string "BUILDCABAL")
, "Type" -=> Just (int 18)
, "Source" -=> Just (string fKey) -- "GHCPKG")
, "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup build --builddir=ldist"))
])
-- ToDo: fix
addRow (newCustomAction
[ "Action" -=> Just (string "UNINSTALL_CABAL")
-- ignore errors
, "Type" -=> Just (int (50+64))
, "Source" -=> Just (string "GHCPKG")
, "Target" -=> Just (string ("unregister " ++ cabal_packageName pkg))
])
addControl :: String -> Control -> IM ()
addControl diaName (Control cname ty pName
(x,y) (w,h)
text as next help) = do
addRow (newControl [ "Dialog_" -=> Just (string diaName)
, "Control" -=> Just (string cname)
, "Type" -=> Just (string $ toControlTypeString ty)
, "X" -=> Just (int x)
, "Y" -=> Just (int y)
, "Width" -=> Just (int width)
, "Height" -=> Just (int height)
, "Attributes" -=> Just (int $ flattenAttr as)
, "Property" -=> fmap string pName
, "Text" -=> mbString text
, "Control_Next" -=> mbString next
, "Help" -=> mbString help
])
case ty of
RadioButtonGroup chs -> do
zipWithM_ addRadioButton [(1::Int)..] chs
return ()
CheckBox onYes -> addCheckBox onYes
_ -> return ()
where
flattenAttr ats = fromIntegral (foldr marshal (0::Int32) ats)
addCheckBox onYes = do
addRow (newCheckBox [ "Property" -=> fmap string pName
, "Value" -=> Just (string onYes)
])
width = w
height =
case ty of
RadioButtonGroup chs -> 20 * length chs
_ -> h
addRadioButton idx (RadioButton txt colStr) =
addRow (newRadioButton
[ "Property" -=> fmap string pName
, "Order" -=> Just (int idx)
, "Value" -=> Just (string colStr)
, "X" -=> Just (int 5)
, "Y" -=> Just (int ((idx-1)*20))
, "Width" -=> Just (int 250)
, "Height" -=> Just (int 15)
, "Text" -=> Just (string txt)
])
marshal mx acc = acc .|.
case mx of
Visible -> 0x01
Enabled -> 0x02
Sunken -> 0x04
Indirect -> 0x08
IntegerControl -> 0x10
RightToLeftReadingOrder -> 0x20
RightAligned -> 0x40
LeftScroll -> 0x80
BiDi -> 0xE0
-- text control attributes
Transparent -> 0x00010000
NoPrefix -> 0x00020000
NoWrap -> 0x00040000
FormatSize -> 0x00080000
UserLanguage -> 0x00100000
-- edit control
MultiLine -> 0x00010000
Password -> 0x00200000
-- progress bar
Progress95 -> 0x00010000
-- volume and directory select combo controls
RemovableVolume -> 0x00010000
FixedVolume -> 0x00020000
RemoteVolume -> 0x00040000
CDRomVolume -> 0x00080000
RAMDiskVolume -> 0x00100000
FloppyVolume -> 0x00200000
-- volume cost list attrs
ShowRollback -> 0x00400000
-- list box and combo box controls attributes
Sorted -> 0x00010000
ComboList -> 0x00020000
-- picture button control attributes
ImageHandle -> 0x00010000
PushLike -> 0x00020000
BitmapAttr -> 0x00040000
Icon -> 0x00080000
FixedSize -> 0x00100000
IconSize16 -> 0x00200000
IconSize32 -> 0x00400000
IconSize48 -> 0x00600000
-- radio button group attributes
HasBorder -> 0x01000000
-- _ -> 0x0
{-
BillboardName String
IndirectPropertyName Label
ProgressControl Int Int String
PropertyName Label
PropertyValue Label
TextControl String
TimeRemaining Int
-}
toControlTypeString tx =
case tx of
PushButton{} -> "PushButton"
PathEdit -> "PathEdit"
Line{} -> "Line"
Text{} -> "Text"
ScrollableText{} -> "ScrollableText"
Bitmap{} -> "Bitmap"
RadioButtonGroup{} -> "RadioButtonGroup"
CheckBox{} -> "CheckBox"
_ -> error ("toControlTypeString: unhandled control")
mbString :: String -> Maybe ColumnValue
mbString "" = Nothing
mbString x = Just (string x)
addControlEvent :: String -> (String, ControlEvent, String, String) -> IM ()
addControlEvent diaName (control, ev, cond, ordering) =
addRow (newControlEvent [ "Dialog_" -=> Just (string diaName)
, "Control_" -=> Just (string control)
, "Event" -=> Just (string (toEventString ev))
, "Argument" -=> toEventArg ev
, "Condition" -=> mbString cond
, "Ordering" -=> mbString ordering
])
addControlCondition :: String -> (String, String, String) -> IM ()
addControlCondition diaName (cName, action, cond) =
addRow (newControlCondition [ "Dialog_" -=> Just (string diaName)
, "Control_" -=> Just (string cName)
, "Action" -=> Just (string action)
, "Condition" -=> Just (string cond)
])
toEventString :: ControlEvent -> String
toEventString x =
case x of
SetProperty p _ -> '[':p ++ "]"
ActionData -> "ActionData"
ActionText -> "ActionText"
AddLocal{} -> "AddLocal"
AddSource{} -> "AddSource"
CheckExistingTargetPath{} -> "CheckExistingTargetPath"
CheckTargetPath{} -> "CheckTargetPath"
DirectoryListNew -> "DirectoryListNew"
DirectoryListOpen -> "DirectoryListOpen"
DirectoryListUp -> "DirectoryListUp"
DoAction{} -> "DoAction"
EnableRollback{} -> "EnableRollback"
EndDialog{} -> "EndDialog"
IgnoreChange -> "IgnoreChange"
NewDialog{} -> "NewDialog"
Reinstall{} -> "Reinstall"
ReinstallMode{} -> "ReinstallMode"
Remove{} -> "Remove"
Reset -> "Reset"
ScriptInProgress -> "ScriptInProgress"
SelectionAction -> "SelectionAction"
SelectionBrowse -> "SelectionBrowse"
SelectionDescription -> "SelectionDescription"
SelectionIcon -> "SelectionIcon"
SelectionNoItems -> "SelectionNoItems"
SelectionPath -> "SelectionPath"
SelectionPathOn -> "SelectionPathOn"
SelectionSize -> "SelectionSize"
SetInstallLevel{} -> "SetInstallLevel"
SetProgress -> "SetProgress"
SetTargetPath{} -> "SetTargetPath"
SpawnDialog{} -> "SpawnDialog"
SpawnWaitDialog{} -> "SpawnWaitDialog"
TimeRemaining -> "TimeRemaining"
ValidateProductID -> "ValidateProductID"
toEventArg :: ControlEvent -> Maybe ColumnValue
toEventArg ce =
case ce of
SetProperty _ "" -> Just (string "{}")
SetProperty _ x -> Just (string x)
AddLocal f -> Just (string f)
AddSource f -> Just (string f)
CheckExistingTargetPath p -> Just (string p)
CheckTargetPath p -> Just (string p)
DoAction a -> Just (string a)
EnableRollback x -> Just (string x)
EndDialog d -> Just (string d)
NewDialog d -> Just (string d)
Reinstall f -> Just (string f)
ReinstallMode f -> Just (string f)
Remove f -> Just (string f)
SetInstallLevel i -> Just (string (show i))
SetTargetPath p -> Just (string p)
SpawnDialog d -> Just (string d)
SpawnWaitDialog d -> Just (string d)
_ -> Nothing
flattenAttrib :: [DiaAttribute] -> Int
flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as)
where
marshal x acc =
acc .|.
case x of
DialogVisible -> 0x1
DialogModal -> 0x2
DialogMinimize -> 0x4
DialogSysModal -> 0x8
DialogKeepModeless -> 0x10
DialogTrackDiskSpace -> 0x20
DialogUseCustomPalette -> 0x40
DialogRightToLeftOrdering -> 0x80
DialogRightAligned -> 0x100
DialogLeftScroll -> 0x200
DialogBiDi -> 0x380
DialogError -> 0x10000