bamse-0.9.3: 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 -> Maybe GhcPackage -> Bool -> Dialog -> IM ()
writeDialog pkg ghcPackage hasLicense
(Dialog diaName cs conds evs
(hc,vc) (w,h) attrs
title 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 title)
, "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")
| otherwise -> (afterDlg, afterDlgCond)
"CustomizeDlg" -> (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" -> "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)
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))
])
mapM_ (\ act ->
addRow (act [ "Action" -=> Just (string "INSTALLGHCPKG")
, "Condition" -=> Just (string ("NOT Installed AND RUNPKGMGR=1"))
, "Sequence" -=> Just (int 6601)
]))
[ newAdminExecuteSequence
, newInstallExecuteSequence
]
mapM_ (\ act ->
addRow (act [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")
, "Condition" -=> Just (string "REMOVE")
, "Sequence" -=> Just (int 6602)
]))
[ newAdminExecuteSequence
, newInstallExecuteSequence
]
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))
])
addControl diaName (Control name ty pName
(x,y) (w,h)
text as next help) = do
addRow (newControl [ "Dialog_" -=> Just (string diaName)
, "Control" -=> Just (string name)
, "Type" -=> Just (string $ toControlTypeString ty)
, "X" -=> Just (int x)
, "Y" -=> Just (int y)
, "Width" -=> Just (int width)
, "Height" -=> Just (int height)
, "Attributes" -=> Just (int $ flattenAttrib 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
flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as)
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 x acc = acc .|.
case x 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 x =
case x 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 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 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 x =
case x 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