-------------------------------------------------------------------- -- | -- Module : Bamse.DiaWriter -- Description : Converting a Dialog type into an MSI dialog. -- Copyright : (c) Sigbjorn Finne, 2004-2009 -- License : BSD3 -- -- Maintainer : Sigbjorn Finne -- 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