nsis 0.3.1 → 0.3.2
raw patch · 45 files changed
+3178/−3163 lines, 45 filesdep +nsisdep +semigroupsPVP ok
version bump matches the API change (PVP)
Dependencies added: nsis, semigroups
API changes (from Hackage documentation)
Files
- CHANGES.txt +2/−0
- Development/NSIS.hs +0/−112
- Development/NSIS/Library.hs +0/−89
- Development/NSIS/Optimise.hs +0/−161
- Development/NSIS/Plugins/Base64.hs +0/−19
- Development/NSIS/Plugins/EnvVarUpdate.hs +0/−63
- Development/NSIS/Plugins/Sections.hs +0/−47
- Development/NSIS/Plugins/Taskbar.hs +0/−10
- Development/NSIS/Plugins/WinMessages.hs +0/−566
- Development/NSIS/Show.hs +0/−140
- Development/NSIS/Sugar.hs +0/−1164
- Development/NSIS/Type.hs +0/−326
- Examples/Base64.hs +0/−27
- Examples/EnvVarUpdate.hs +0/−51
- Examples/Example1.hs +0/−44
- Examples/Example2.hs +0/−99
- Examples/Finish.hs +0/−23
- Examples/Primes.hs +0/−66
- Examples/Radio.hs +0/−33
- Examples/Taskbar.hs +0/−27
- Examples/WinMessages.hs +0/−26
- Main.hs +0/−67
- README.md +1/−1
- nsis.cabal +8/−2
- src/Development/NSIS.hs +113/−0
- src/Development/NSIS/Library.hs +89/−0
- src/Development/NSIS/Optimise.hs +161/−0
- src/Development/NSIS/Plugins/Base64.hs +19/−0
- src/Development/NSIS/Plugins/EnvVarUpdate.hs +63/−0
- src/Development/NSIS/Plugins/Sections.hs +47/−0
- src/Development/NSIS/Plugins/Taskbar.hs +10/−0
- src/Development/NSIS/Plugins/WinMessages.hs +566/−0
- src/Development/NSIS/Show.hs +140/−0
- src/Development/NSIS/Sugar.hs +1170/−0
- src/Development/NSIS/Type.hs +326/−0
- test/Examples/Base64.hs +27/−0
- test/Examples/EnvVarUpdate.hs +51/−0
- test/Examples/Example1.hs +44/−0
- test/Examples/Example2.hs +99/−0
- test/Examples/Finish.hs +23/−0
- test/Examples/Primes.hs +66/−0
- test/Examples/Radio.hs +33/−0
- test/Examples/Taskbar.hs +27/−0
- test/Examples/WinMessages.hs +26/−0
- test/Main.hs +67/−0
CHANGES.txt view
@@ -1,5 +1,7 @@ Changelog for NSIS +0.3.2+ Support Semigroup class 0.3.1 #11, add unsafeInject and unsafeInjectGlobal #10, add unicode function
− Development/NSIS.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | NSIS (Nullsoft Scriptable Install System, <http://nsis.sourceforge.net/>) is a tool that allows programmers--- to create installers for Windows.--- This library provides an alternative syntax for NSIS scripts, as an embedded Haskell language, removing much--- of the hard work in developing an install script. Simple NSIS installers should look mostly the same, complex ones should--- be significantly more maintainable.------ As a simple example of using this library:------ @---import "Development.NSIS"------main = writeFile \"example1.nsi\" $ 'nsis' $ do--- 'name' \"Example1\" -- The name of the installer--- 'outFile' \"example1.exe\" -- Where to produce the installer--- 'installDir' \"$DESKTOP/Example1\" -- The default installation directory--- 'requestExecutionLevel' 'User' -- Request application privileges for Windows Vista--- -- Pages to display--- 'page' 'Directory' -- Pick where to install--- 'page' 'InstFiles' -- Give a progress bar while installing--- -- Groups fo files to install--- 'section' \"\" [] $ do--- 'setOutPath' \"$INSTDIR\" -- Where to install files in this section--- 'file' [] \"Example1.hs\" -- File to put into this section--- @------ The file @example1.nsi@ can now be processed with @makensis@ to produce the installer @example1.exe@.--- For more examples, see the @Examples@ source directory.------ Much of the documentation from the Installer section is taken from the NSIS documentation.-module Development.NSIS- (- -- * Core types- nsis, nsisNoOptimise, Action, Exp, Value,- -- * Scripting- -- ** Variables- share, scope, constant, constant_, mutable, mutable_, (@=),- -- ** Typed variables- mutableInt, constantInt, mutableInt_, constantInt_, mutableStr, constantStr, mutableStr_, constantStr_,- -- ** Control Flow- iff, iff_, while, loop, onError,- (?), (%&&), (%||),- Label, newLabel, label, goto,- -- ** Expressions- str, int, bool,- (%==), (%/=), (%<=), (%<), (%>=), (%>),- true, false, not_,- strRead, strShow,- (&), strConcat, strLength, strTake, strDrop, strReplace, strIsPrefixOf, strIsSuffixOf, strUnlines, strCheck,- -- ** File system manipulation- FileHandle, fileOpen, fileWrite, fileClose, withFile', writeFile', writeFileLines,- rmdir, delete, copyFiles,- getFileTime, fileExists, findEach,- createDirectory, createShortcut,- -- ** Registry manipulation- readRegStr, deleteRegKey, deleteRegValue, writeRegStr, writeRegExpandStr, writeRegDWORD,- -- ** Environment variables- envVar,- -- ** Process execution- exec, execWait, execShell, sleep, abort,- -- ** Windows- HWND, hwndParent, findWindow, getDlgItem, sendMessage,- -- ** Plugins- plugin, push, pop, exp_,- addPluginDir,- -- * Installer- -- ** Global installer options- name, outFile, installDir, setCompressor,- installIcon, uninstallIcon, headerImage,- installDirRegKey, allowRootDirInstall, caption,- showInstDetails, showUninstDetails, unicode,- -- ** Sections- SectionId, section, sectionGroup, newSectionId,- sectionSetText, sectionGetText, sectionSet, sectionGet,- uninstall, page, unpage, finishOptions,- -- ** Events- event, onSelChange,- onPageShow, onPagePre, onPageLeave,- -- ** Section commands- file, alwaysNonFatal, writeUninstaller, alert, setOutPath, messageBox, requestExecutionLevel,- hideProgress, detailPrint, setDetailsPrint,- -- * Escape hatch- unsafeInject, unsafeInjectGlobal,- -- * Settings- Compressor(..), HKEY(..), MessageBoxType(..), Attrib(..), Page(..), Level(..), Visibility(..),- FileMode(..), SectionFlag(..), ShowWindow(..), FinishOptions(..), DetailsPrint(..)- ) where--import Control.Monad-import Development.NSIS.Sugar-import Development.NSIS.Show-import Development.NSIS.Optimise-import Development.NSIS.Library----- | Create the contents of an NSIS script from an installer specification.------ Beware, 'unsafeInject' and 'unsafeInjectGlobal' may break 'nsis'. The--- optimizer relies on invariants that may not hold when arbitrary lines are--- injected. Consider using 'nsisNoOptimise' if problems arise.-nsis :: Action a -> String-nsis = unlines . showNSIS . optimise . runAction . void----- | Like 'nsis', but don't try and optimise the resulting NSIS script.------ Useful to figure out how the underlying installer works, or if you believe--- the optimisations are introducing bugs. Please do report any such bugs,--- especially if you aren't using 'unsafeInject' or 'unsafeInjectGlobal'!-nsisNoOptimise :: Action a -> String-nsisNoOptimise = unlines . showNSIS . runAction . void
− Development/NSIS/Library.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Development.NSIS.Library where--import Control.Monad-import Development.NSIS.Sugar----- | Replace one string with another string, in a target string. As some examples:------ > strReplace "t" "XX" "test" %== "XXesXX"--- > strReplace "ell" "" "hello world" %== "ho world"-strReplace :: Exp String -> Exp String -> Exp String -> Exp String-strReplace from to str = do- from <- constant_ from- to <- constant_ to- str <- constant_ str- scope $ do- rest <- mutable "REST" str- res <- mutable "RES" ""- while (rest %/= "") $ do- iff (from `strIsPrefixOf` rest)- (do- res @= res & to- rest @= strDrop (strLength from) rest)- (do- res @= res & strTake 1 rest- rest @= strDrop 1 rest)- res---- | NSIS (the underlying installer, not this library) uses fixed length string buffers,--- defaulting to 1024 bytes. Any strings longer than--- the limit may cause truncation or segfaults. You can get builds supporting longer strings--- from <http://nsis.sourceforge.net/Special_Builds>.------ Given @strCheck msg val@, if @val@ exceeds the limit it will 'abort' with @msg@, otherwise--- it will return 'val'.-strCheck :: Exp String -> Exp String -> Exp String-strCheck msg x = share x $ \x -> do- let special = "@!!_NSIS"- iff_ (not_ $ special `strIsSuffixOf` (x & special)) $ do- void $ messageBox [MB_ICONSTOP] $ "ERROR: String limit exceeded,\n" & msg- abort $ "ERROR: String limit exceeded, " & msg- x----- | Is the first string a prefix of the second.-strIsPrefixOf :: Exp String -> Exp String -> Exp Bool-strIsPrefixOf x y = share x $ \x -> share y $ \y ->- strTake (strLength x) y %== x---- | Is the first string a prefix of the second.-strIsSuffixOf :: Exp String -> Exp String -> Exp Bool-strIsSuffixOf x y = share x $ \x -> share y $ \y ->- strDrop (strLength y - strLength x) y %== x----- | Join together a list of strings with @\\r\\n@ after each line. Note that unlike standard 'unlines',--- we use the Windows convention line separator.-strUnlines :: [Exp String] -> Exp String-strUnlines = strConcat . map (& "\r\n")----- | Write a file comprising of a set of lines.-writeFileLines :: Exp FilePath -> [Exp String] -> Action ()-writeFileLines a b = withFile' ModeWrite a $ \hdl ->- forM_ b $ \s -> fileWrite hdl $ s & "\r\n"---infixr 3 %&&-infixr 2 %||---- | Short circuiting boolean operators, equivalent to '&&' and '||' but on 'Exp'.-(%&&), (%||) :: Exp Bool -> Exp Bool -> Exp Bool-(%&&) a b = a ? (b, false)-(%||) a b = a ? (true, b)----- | With a 'fileOpen' perform some action, then automatically call 'fileClose'.--- If the action argument jumps out of the section then the 'fileClose' call will be missed.-withFile' :: FileMode -> Exp FilePath -> (Exp FileHandle -> Action ()) -> Action ()-withFile' mode name act = do- hdl <- fileOpen mode name- act hdl- fileClose hdl---- | Write a file, like 'writeFile'.-writeFile' :: Exp FilePath -> Exp String -> Action ()-writeFile' name contents = withFile' ModeWrite name $ \hdl -> fileWrite hdl contents
− Development/NSIS/Optimise.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Development.NSIS.Optimise(optimise) where--import Development.NSIS.Type-import Data.Generics.Uniplate.Data-import Data.List-import Data.Maybe----- before: secret = 1021, primes = 109--optimise :: [NSIS] -> [NSIS]-optimise =- -- allow Label 0- rep (elimDeadLabel . useLabel0) .- -- disallow Label 0- rep (elimDeadLabel . elimAfterGoto . deadAssign . assignSwitch . dullGoto . knownCompare . elimLabeledGoto . elimDeadVar)---rep :: ([NSIS] -> [NSIS]) -> [NSIS] -> [NSIS]-rep f x = g (measure x) x- where- g n1 x1 = if n2 < n1 then g n2 x2 else x2- where x2 = f $ f $ f $ f x1- n2 = measure x2- measure x = length (universeBi x :: [NSIS])---useLabel0 :: [NSIS] -> [NSIS]-useLabel0 = map (descendBi useLabel0) . f- where- f (x:Labeled next:xs)- | null (children x :: [NSIS]) -- must not be a block with nested instructions- = descendBi (\i -> if i == next then Label 0 else i) x : Labeled next : f xs- f (x:xs) = x : f xs- f [] = []----- Label whose next statement is a good, -elimLabeledGoto :: [NSIS] -> [NSIS]-elimLabeledGoto x = transformBi f x- where- f (Labeled x) = Labeled x- f x | null (children x) = descendBi moveBounce x- | otherwise = x-- moveBounce x = fromMaybe x $ lookup x bounce- bounce = flip concatMap (universe x) $ \x -> case x of- Labeled x:Goto y:_ -> [(x,y)]- Labeled x:Labeled y:_ -> [(x,y)]- _ -> []----- Delete variables which are only assigned, never read from-elimDeadVar :: [NSIS] -> [NSIS]-elimDeadVar x = transform f x- where- f (Assign x _:xs) | x `elem` unused = xs- f xs = xs-- unused = nub assign \\ nub used- used = every \\ assign- every = universeBi x- assign = [x | Assign x _ <- universeBi x]--jumpy Goto{} = True-jumpy StrCmpS{} = True-jumpy IntCmp{} = True-jumpy IfErrors{} = True-jumpy IfFileExists{} = True-jumpy MessageBox{} = True-jumpy _ = False----- Eliminate any code after a goto, until a label-elimAfterGoto :: [NSIS] -> [NSIS]-elimAfterGoto x = transformBi f x- where- f (x:xs) | jumpy x = x : g xs- f x = x-- g (Labeled x:xs) = Labeled x:xs- g (x:xs) = g xs- g x = x----- Be careful to neither introduce or remove label based errors-elimDeadLabel :: [NSIS] -> [NSIS]-elimDeadLabel x = transform f x- where- f (Labeled x:xs) | x `elem` unused = xs- f xs = xs-- unused = nub label \\ nub gotos- gotos = every \\ label- every = universeBi x- label = [x | Labeled x <- universeBi x]---dullGoto :: [NSIS] -> [NSIS]-dullGoto = transform f- where- f (Goto l1:Labeled l2:xs) | l1 == l2 = Labeled l2 : xs- f x = x----- A tricky one! Comparison after jump-knownCompare :: [NSIS] -> [NSIS]-knownCompare x = transform f x- where- f (Assign var val : StrCmpS a b yes no : xs)- | a == [Var_ var], Just eq <- isEqual b val- = Assign var val : Goto (if eq then yes else no) : xs-- -- grows, but only a finite amount- f (Assign var val : Labeled l : StrCmpS a b yes no : xs)- | a == [Var_ var], Just eq <- isEqual b val- = Assign var val : Goto (if eq then yes else no) : Labeled l : StrCmpS a b yes no : xs-- f (Assign var val : c : xs) | jumpy c = Assign var val : transformBi g c : xs- where- g l | Just (StrCmpS a b yes no) <- lookup l cmps- , a == [Var_ var], Just eq <- isEqual b val- = if eq then yes else no- g l = l- f x = x-- cmps = [(l,cmp) | Labeled l : cmp@StrCmpS{} : _ <- universeBi x]---isEqual :: Val -> Val -> Maybe Bool-isEqual x y | x == y = Just True- | isLit x, isLit y = Just False- | otherwise = Nothing- where- isLit = all isLiteral- isLiteral Literal{} = True- isLiteral _ = False---assignSwitch :: [NSIS] -> [NSIS]-assignSwitch = transform f- where- -- this rule just switches the assignment, back and forth, ad infinitum- -- not very principled!- f (IntOp out1 a b c : Assign other ([Var_ out2]) : xs)- | out1 == out2- = IntOp other a b c : Assign out1 ([Var_ other]) : xs- f x = x---deadAssign :: [NSIS] -> [NSIS]-deadAssign = transform f- where- f (Assign v x:xs) | isDead v xs = xs- f xs = xs-- isDead v (Labeled _:xs) = isDead v xs- isDead v (Assign v2 x:xs) = v `notElem` universeBi x && (v == v2 || isDead v xs)- isDead v _ = False
− Development/NSIS/Plugins/Base64.hs
@@ -1,19 +0,0 @@---- | Base64 plugin: <http://nsis.sourceforge.net/Base64_plug-in>-module Development.NSIS.Plugins.Base64(encrypt, decrypt) where--import Development.NSIS----- | Base64 data encryption.-encrypt :: Exp String -> Exp String-encrypt x = share x $ \x -> do- plugin "Base64" "Encrypt" [exp_ x, exp_ $ strLength x]- pop----- | Base64 decryption. Reverse of 'encrypt'.-decrypt :: Exp String -> Exp String-decrypt x = share x $ \x -> do- plugin "Base64" "Decrypt" [exp_ x, exp_ $ strLength x]- pop
− Development/NSIS/Plugins/EnvVarUpdate.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Module for updating environment variables. All functions take either 'HKLM' to modify the--- variable for the machine, or 'HKCU' to modify for the user.------ /Warning:/ If you are modifying PATH, make sure you use a special build of NSIS which can cope--- with longer strings, or you will corrupt your users path.-module Development.NSIS.Plugins.EnvVarUpdate(- getEnvVar, setEnvVar, deleteEnvVar,- setEnvVarAppend, setEnvVarPrepend, setEnvVarRemove- ) where--import Development.NSIS-import Development.NSIS.Plugins.WinMessages-import Control.Monad-import Data.String---resolve :: HKEY -> String-resolve h | h == HKLM || h == HKEY_LOCAL_MACHINE = "SYSTEM/CurrentControlSet/Control/Session Manager/Environment"- | h == HKCU || h == HKEY_CURRENT_USER = "Environment"- | otherwise = error $ "Development.NSIS.Plugins.EnvVarUpdate, must use either HKLM or HKCU, got: " ++ show h----- | Given a string, and a ; separated variable, remove the string from it if it is present.-remove :: Exp String -> Exp String -> Exp String-remove x xs = share x $ \x -> share xs $ \xs -> do- xs <- mutable_ xs- xs @= strReplace (";" & x & ";") ";" xs- while ((x & ";") `strIsPrefixOf` xs) $ xs @= strDrop (strLength x + 1) xs- while ((";" & x) `strIsSuffixOf` xs) $ xs @= strTake (strLength xs - 1 - strLength x) xs- iff_ (x %== xs) $ xs @= ""- xs----- | Set an environment variable by writing to the registry.-setEnvVar :: HKEY -> Exp String -> Exp String -> Action ()-setEnvVar h key val = do- writeRegExpandStr h (fromString $ resolve h) key (strCheck ("setting environment variable %" & key & "%") val)- void $ sendMessage [Timeout 5000] hwnd_BROADCAST wm_WININICHANGE (0 :: Exp Int) ("STR:Environment" :: Exp String)----- | Read a variable from the registry. If you are not modifying the variable--- you should use 'envVar' instead.-getEnvVar :: HKEY -> Exp String -> Exp String-getEnvVar h key = strCheck ("reading environment variable %" & key & "%") $ readRegStr h (fromString $ resolve h) key----- | Delete the environment variable in the registry.-deleteEnvVar :: HKEY -> Exp String -> Action ()-deleteEnvVar h key = do- deleteRegValue h (fromString $ resolve h) key- void $ sendMessage [Timeout 5000] hwnd_BROADCAST wm_WININICHANGE (0 :: Exp Int) ("STR:Environment" :: Exp String)---setEnvVarAppend :: HKEY -> Exp String -> Exp String -> Action ()-setEnvVarAppend h key val = share val $ \val -> setEnvVar h key $ remove val (getEnvVar h key) & ";" & val--setEnvVarPrepend :: HKEY -> Exp String -> Exp String -> Action ()-setEnvVarPrepend h key val = share val $ \val -> setEnvVar h key $ val & ";" & remove val (getEnvVar h key)--setEnvVarRemove :: HKEY -> Exp String -> Exp String -> Action ()-setEnvVarRemove h key val = setEnvVar h key $ remove val $ getEnvVar h key
− Development/NSIS/Plugins/Sections.hs
@@ -1,47 +0,0 @@---- | Plugin to change how many sections can be selected at once.-module Development.NSIS.Plugins.Sections(atMostOneSection, exactlyOneSection) where--import Control.Monad-import Development.NSIS---atMostOneSection :: [SectionId] -> Action ()-atMostOneSection xs = do- selected <- mutableInt_ (-1)- let ensure = do- -- find the lowest selected, which isn't already equal to selected- prev <- constant_ selected- forM_ (reverse $ zip [0..] xs) $ \(i,x) -> do- iff_ (prev %/= int i %&& sectionGet x SF_Selected) $ do- selected @= int i-- -- ensure only (at most) selected is actually selected- forM_ (zip [0..] xs) $ \(i,x) -> do- iff_ (selected %/= int i %&& sectionGet x SF_Selected) $- sectionSet x SF_Selected false- ensure- onSelChange ensure--exactlyOneSection :: [SectionId] -> Action ()-exactlyOneSection xs = do- selected <- mutableInt_ (-1)-- let ensure = do- -- find the lowest selected, which isn't already equal to selected- prev <- constant_ selected- forM_ (reverse $ zip [0..] xs) $ \(i,x) ->- iff_ (prev %/= int i %&& sectionGet x SF_Selected) $- selected @= int i- iff_ (selected %== (-1)) $- selected @= 0-- -- ensure only selected is actually selected- forM_ (zip [0..] xs) $ \(i,x) -> do- let b = selected %== int i- iff_ (b %/= sectionGet x SF_Selected) $- sectionSet x SF_Selected b-- ensure- onSelChange ensure-
− Development/NSIS/Plugins/Taskbar.hs
@@ -1,10 +0,0 @@---- | Windows 7 Taskbar Progress plugin: <http://nsis.sourceforge.net/TaskbarProgress_plug-in>-module Development.NSIS.Plugins.Taskbar(taskbar) where--import Development.NSIS----- | Enable Windows 7 taskbar plugin, called anywhere.-taskbar :: Action ()-taskbar = onPageShow InstFiles $ plugin "w7tbp" "Start" []
− Development/NSIS/Plugins/WinMessages.hs
@@ -1,566 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-|-List of common Windows Messages--2005 Shengalts Aleksander aka Instructor <Shengalts@mail.ru>--For usage example see @Examples\/WinMessages.hs@.--> Prefix Message category-> --------------------------> SW ShowWindow Commands-> BM Button control-> CB Combo box control-> EM Edit control-> LB List box control-> WM General window-> ABM Application desktop toolbar-> DBT Device-> DM Default push button control-> HDM Header control-> LVM List view control-> SB Status bar window-> SBM Scroll bar control-> STM Static control-> TCM Tab control-> PBM Progress bar--> NOT included messages (WM_USER + X)-> ------------------------------------> CBEM Extended combo box control-> CDM Common dialog box-> DL Drag list box-> DTM Date and time picker control-> HKM Hot key control-> IPM IP address control-> MCM Month calendar control-> PGM Pager control-> PSM Property sheet-> RB Rebar control-> TB Toolbar-> TBM Trackbar-> TTM Tooltip control-> TVM Tree-view control-> UDM Up-down control--}-module Development.NSIS.Plugins.WinMessages where--hwnd_BROADCAST = 0xFFFF---- ShowWindow Commands-sw_HIDE = 0-sw_SHOWNORMAL = 1-sw_NORMAL = 1-sw_SHOWMINIMIZED = 2-sw_SHOWMAXIMIZED = 3-sw_MAXIMIZE = 3-sw_SHOWNOACTIVATE = 4-sw_SHOW = 5-sw_MINIMIZE = 6-sw_SHOWMINNOACTIVE = 7-sw_SHOWNA = 8-sw_RESTORE = 9-sw_SHOWDEFAULT = 10-sw_FORCEMINIMIZE = 11-sw_MAX = 11---- Button Control Messages ---bm_CLICK = 0x00F5-bm_GETCHECK = 0x00F0-bm_GETIMAGE = 0x00F6-bm_GETSTATE = 0x00F2-bm_SETCHECK = 0x00F1-bm_SETIMAGE = 0x00F7-bm_SETSTATE = 0x00F3-bm_SETSTYLE = 0x00F4--bst_UNCHECKED = 0-bst_CHECKED = 1-bst_INDETERMINATE = 2-bst_PUSHED = 4-bst_FOCUS = 8---- Combo Box Messages ---cb_ADDSTRING = 0x0143-cb_DELETESTRING = 0x0144-cb_DIR = 0x0145-cb_FINDSTRING = 0x014C-cb_FINDSTRINGEXACT = 0x0158-cb_GETCOUNT = 0x0146-cb_GETCURSEL = 0x0147-cb_GETDROPPEDCONTROLRECT = 0x0152-cb_GETDROPPEDSTATE = 0x0157-cb_GETDROPPEDWIDTH = 0x015f-cb_GETEDITSEL = 0x0140-cb_GETEXTENDEDUI = 0x0156-cb_GETHORIZONTALEXTENT = 0x015d-cb_GETITEMDATA = 0x0150-cb_GETITEMHEIGHT = 0x0154-cb_GETLBTEXT = 0x0148-cb_GETLBTEXTLEN = 0x0149-cb_GETLOCALE = 0x015A-cb_GETTOPINDEX = 0x015b-cb_INITSTORAGE = 0x0161-cb_INSERTSTRING = 0x014A-cb_LIMITTEXT = 0x0141-cb_MSGMAX = 0x015B -- 0x0162 0x0163-cb_MULTIPLEADDSTRING = 0x0163-cb_RESETCONTENT = 0x014B-cb_SELECTSTRING = 0x014D-cb_SETCURSEL = 0x014E-cb_SETDROPPEDWIDTH = 0x0160-cb_SETEDITSEL = 0x0142-cb_SETEXTENDEDUI = 0x0155-cb_SETHORIZONTALEXTENT = 0x015e-cb_SETITEMDATA = 0x0151-cb_SETITEMHEIGHT = 0x0153-cb_SETLOCALE = 0x0159-cb_SETTOPINDEX = 0x015c-cb_SHOWDROPDOWN = 0x014F--cb_ERR = -1---- Edit Control Messages ---em_CANUNDO = 0x00C6-em_CHARFROMPOS = 0x00D7-em_EMPTYUNDOBUFFER = 0x00CD-em_EXLIMITTEXT = 0x0435-em_FMTLINES = 0x00C8-em_GETFIRSTVISIBLELINE = 0x00CE-em_GETHANDLE = 0x00BD-em_GETIMESTATUS = 0x00D9-em_GETLIMITTEXT = 0x00D5-em_GETLINE = 0x00C4-em_GETLINECOUNT = 0x00BA-em_GETMARGINS = 0x00D4-em_GETMODIFY = 0x00B8-em_GETPASSWORDCHAR = 0x00D2-em_GETRECT = 0x00B2-em_GETSEL = 0x00B0-em_GETTHUMB = 0x00BE-em_GETWORDBREAKPROC = 0x00D1-em_LIMITTEXT = 0x00C5-em_LINEFROMCHAR = 0x00C9-em_LINEINDEX = 0x00BB-em_LINELENGTH = 0x00C1-em_LINESCROLL = 0x00B6-em_POSFROMCHAR = 0x00D6-em_REPLACESEL = 0x00C2-em_SCROLL = 0x00B5-em_SCROLLCARET = 0x00B7-em_SETHANDLE = 0x00BC-em_SETIMESTATUS = 0x00D8-em_SETLIMITTEXT = 0x00C5 -- Same as EM_LIMITTEXT-em_SETMARGINS = 0x00D3-em_SETMODIFY = 0x00B9-em_SETPASSWORDCHAR = 0x00CC-em_SETREADONLY = 0x00CF-em_SETRECT = 0x00B3-em_SETRECTNP = 0x00B4-em_SETSEL = 0x00B1-em_SETTABSTOPS = 0x00CB-em_SETWORDBREAKPROC = 0x00D0-em_UNDO = 0x00C7---- Listbox Messages ---lb_ADDFILE = 0x0196-lb_ADDSTRING = 0x0180-lb_DELETESTRING = 0x0182-lb_DIR = 0x018D-lb_FINDSTRING = 0x018F-lb_FINDSTRINGEXACT = 0x01A2-lb_GETANCHORINDEX = 0x019D-lb_GETCARETINDEX = 0x019F-lb_GETCOUNT = 0x018B-lb_GETCURSEL = 0x0188-lb_GETHORIZONTALEXTENT = 0x0193-lb_GETITEMDATA = 0x0199-lb_GETITEMHEIGHT = 0x01A1-lb_GETITEMRECT = 0x0198-lb_GETLOCALE = 0x01A6-lb_GETSEL = 0x0187-lb_GETSELCOUNT = 0x0190-lb_GETSELITEMS = 0x0191-lb_GETTEXT = 0x0189-lb_GETTEXTLEN = 0x018A-lb_GETTOPINDEX = 0x018E-lb_INITSTORAGE = 0x01A8-lb_INSERTSTRING = 0x0181-lb_ITEMFROMPOINT = 0x01A9-lb_MSGMAX = 0x01A8 -- 0x01B0 0x01B1-lb_MULTIPLEADDSTRING = 0x01B1-lb_RESETCONTENT = 0x0184-lb_SELECTSTRING = 0x018C-lb_SELITEMRANGE = 0x019B-lb_SELITEMRANGEEX = 0x0183-lb_SETANCHORINDEX = 0x019C-lb_SETCARETINDEX = 0x019E-lb_SETCOLUMNWIDTH = 0x0195-lb_SETCOUNT = 0x01A7-lb_SETCURSEL = 0x0186-lb_SETHORIZONTALEXTENT = 0x0194-lb_SETITEMDATA = 0x019A-lb_SETITEMHEIGHT = 0x01A0-lb_SETLOCALE = 0x01A5-lb_SETSEL = 0x0185-lb_SETTABSTOPS = 0x0192-lb_SETTOPINDEX = 0x0197--lb_ERR = -1---- Window Messages ---wm_ACTIVATE = 0x0006-wm_ACTIVATEAPP = 0x001C-wm_AFXFIRST = 0x0360-wm_AFXLAST = 0x037F-wm_APP = 0x8000-wm_APPCOMMAND = 0x0319-wm_ASKCBFORMATNAME = 0x030C-wm_CANCELJOURNAL = 0x004B-wm_CANCELMODE = 0x001F-wm_CAPTURECHANGED = 0x0215-wm_CHANGECBCHAIN = 0x030D-wm_CHANGEUISTATE = 0x0127-wm_CHAR = 0x0102-wm_CHARTOITEM = 0x002F-wm_CHILDACTIVATE = 0x0022-wm_CLEAR = 0x0303-wm_CLOSE = 0x0010-wm_COMMAND = 0x0111-wm_COMMNOTIFY = 0x0044 -- no longer suported-wm_COMPACTING = 0x0041-wm_COMPAREITEM = 0x0039-wm_CONTEXTMENU = 0x007B-wm_CONVERTREQUESTEX = 0x108-wm_COPY = 0x0301-wm_COPYDATA = 0x004A-wm_CREATE = 0x0001-wm_CTLCOLOR = 0x0019-wm_CTLCOLORBTN = 0x0135-wm_CTLCOLORDLG = 0x0136-wm_CTLCOLOREDIT = 0x0133-wm_CTLCOLORLISTBOX = 0x0134-wm_CTLCOLORMSGBOX = 0x0132-wm_CTLCOLORSCROLLBAR = 0x0137-wm_CTLCOLORSTATIC = 0x0138-wm_CUT = 0x0300-wm_DDE_FIRST = 0x3E0-wm_DEADCHAR = 0x0103-wm_DELETEITEM = 0x002D-wm_DESTROY = 0x0002-wm_DESTROYCLIPBOARD = 0x0307-wm_DEVICECHANGE = 0x0219-wm_DEVMODECHANGE = 0x001B-wm_DISPLAYCHANGE = 0x007E-wm_DRAWCLIPBOARD = 0x0308-wm_DRAWITEM = 0x002B-wm_DROPFILES = 0x0233-wm_ENABLE = 0x000A-wm_ENDSESSION = 0x0016-wm_ENTERIDLE = 0x0121-wm_ENTERMENULOOP = 0x0211-wm_ENTERSIZEMOVE = 0x0231-wm_ERASEBKGND = 0x0014-wm_EXITMENULOOP = 0x0212-wm_EXITSIZEMOVE = 0x0232-wm_FONTCHANGE = 0x001D-wm_GETDLGCODE = 0x0087-wm_GETFONT = 0x0031-wm_GETHOTKEY = 0x0033-wm_GETICON = 0x007F-wm_GETMINMAXINFO = 0x0024-wm_GETOBJECT = 0x003D-wm_GETTEXT = 0x000D-wm_GETTEXTLENGTH = 0x000E-wm_HANDHELDFIRST = 0x0358-wm_HANDHELDLAST = 0x035F-wm_HELP = 0x0053-wm_HOTKEY = 0x0312-wm_HSCROLL = 0x0114-wm_HSCROLLCLIPBOARD = 0x030E-wm_ICONERASEBKGND = 0x0027-wm_IME_CHAR = 0x0286-wm_IME_COMPOSITION = 0x010F-wm_IME_COMPOSITIONFULL = 0x0284-wm_IME_CONTROL = 0x0283-wm_IME_ENDCOMPOSITION = 0x010E-wm_IME_KEYDOWN = 0x0290-wm_IME_KEYLAST = 0x010F-wm_IME_KEYUP = 0x0291-wm_IME_NOTIFY = 0x0282-wm_IME_REQUEST = 0x0288-wm_IME_SELECT = 0x0285-wm_IME_SETCONTEXT = 0x0281-wm_IME_STARTCOMPOSITION = 0x010D-wm_INITDIALOG = 0x0110-wm_INITMENU = 0x0116-wm_INITMENUPOPUP = 0x0117-wm_INPUT = 0x00FF-wm_INPUTLANGCHANGE = 0x0051-wm_INPUTLANGCHANGEREQUEST = 0x0050-wm_KEYDOWN = 0x0100-wm_KEYFIRST = 0x0100-wm_KEYLAST = 0x0108-wm_KEYUP = 0x0101-wm_KILLFOCUS = 0x0008-wm_LBUTTONDBLCLK = 0x0203-wm_LBUTTONDOWN = 0x0201-wm_LBUTTONUP = 0x0202-wm_MBUTTONDBLCLK = 0x0209-wm_MBUTTONDOWN = 0x0207-wm_MBUTTONUP = 0x0208-wm_MDIACTIVATE = 0x0222-wm_MDICASCADE = 0x0227-wm_MDICREATE = 0x0220-wm_MDIDESTROY = 0x0221-wm_MDIGETACTIVE = 0x0229-wm_MDIICONARRANGE = 0x0228-wm_MDIMAXIMIZE = 0x0225-wm_MDINEXT = 0x0224-wm_MDIREFRESHMENU = 0x0234-wm_MDIRESTORE = 0x0223-wm_MDISETMENU = 0x0230-wm_MDITILE = 0x0226-wm_MEASUREITEM = 0x002C-wm_MENUCHAR = 0x0120-wm_MENUCOMMAND = 0x0126-wm_MENUDRAG = 0x0123-wm_MENUGETOBJECT = 0x0124-wm_MENURBUTTONUP = 0x0122-wm_MENUSELECT = 0x011F-wm_MOUSEACTIVATE = 0x0021-wm_MOUSEFIRST = 0x0200-wm_MOUSEHOVER = 0x02A1-wm_MOUSELAST = 0x0209 -- 0x020A 0x020D-wm_MOUSELEAVE = 0x02A3-wm_MOUSEMOVE = 0x0200-wm_MOUSEWHEEL = 0x020A-wm_MOVE = 0x0003-wm_MOVING = 0x0216-wm_NCACTIVATE = 0x0086-wm_NCCALCSIZE = 0x0083-wm_NCCREATE = 0x0081-wm_NCDESTROY = 0x0082-wm_NCHITTEST = 0x0084-wm_NCLBUTTONDBLCLK = 0x00A3-wm_NCLBUTTONDOWN = 0x00A1-wm_NCLBUTTONUP = 0x00A2-wm_NCMBUTTONDBLCLK = 0x00A9-wm_NCMBUTTONDOWN = 0x00A7-wm_NCMBUTTONUP = 0x00A8-wm_NCMOUSEHOVER = 0x02A0-wm_NCMOUSELEAVE = 0x02A2-wm_NCMOUSEMOVE = 0x00A0-wm_NCPAINT = 0x0085-wm_NCRBUTTONDBLCLK = 0x00A6-wm_NCRBUTTONDOWN = 0x00A4-wm_NCRBUTTONUP = 0x00A5-wm_NCXBUTTONDBLCLK = 0x00AD-wm_NCXBUTTONDOWN = 0x00AB-wm_NCXBUTTONUP = 0x00AC-wm_NEXTDLGCTL = 0x0028-wm_NEXTMENU = 0x0213-wm_NOTIFY = 0x004E-wm_NOTIFYFORMAT = 0x0055-wm_NULL = 0x0000-wm_PAINT = 0x000F-wm_PAINTCLIPBOARD = 0x0309-wm_PAINTICON = 0x0026-wm_PALETTECHANGED = 0x0311-wm_PALETTEISCHANGING = 0x0310-wm_PARENTNOTIFY = 0x0210-wm_PASTE = 0x0302-wm_PENWINFIRST = 0x0380-wm_PENWINLAST = 0x038F-wm_POWER = 0x0048-wm_POWERBROADCAST = 0x0218-wm_PRINT = 0x0317-wm_PRINTCLIENT = 0x0318-wm_QUERYDRAGICON = 0x0037-wm_QUERYENDSESSION = 0x0011-wm_QUERYNEWPALETTE = 0x030F-wm_QUERYOPEN = 0x0013-wm_QUERYUISTATE = 0x0129-wm_QUEUESYNC = 0x0023-wm_QUIT = 0x0012-wm_RBUTTONDBLCLK = 0x0206-wm_RBUTTONDOWN = 0x0204-wm_RBUTTONUP = 0x0205-wm_RASDIALEVENT = 0xCCCD-wm_RENDERALLFORMATS = 0x0306-wm_RENDERFORMAT = 0x0305-wm_SETCURSOR = 0x0020-wm_SETFOCUS = 0x0007-wm_SETFONT = 0x0030-wm_SETHOTKEY = 0x0032-wm_SETICON = 0x0080-wm_SETREDRAW = 0x000B-wm_SETTEXT = 0x000C-wm_SETTINGCHANGE = 0x001A -- Same as WM_WININICHANGE-wm_SHOWWINDOW = 0x0018-wm_SIZE = 0x0005-wm_SIZECLIPBOARD = 0x030B-wm_SIZING = 0x0214-wm_SPOOLERSTATUS = 0x002A-wm_STYLECHANGED = 0x007D-wm_STYLECHANGING = 0x007C-wm_SYNCPAINT = 0x0088-wm_SYSCHAR = 0x0106-wm_SYSCOLORCHANGE = 0x0015-wm_SYSCOMMAND = 0x0112-wm_SYSDEADCHAR = 0x0107-wm_SYSKEYDOWN = 0x0104-wm_SYSKEYUP = 0x0105-wm_TABLET_FIRST = 0x02C0-wm_TABLET_LAST = 0x02DF-wm_THEMECHANGED = 0x031A-wm_TCARD = 0x0052-wm_TIMECHANGE = 0x001E-wm_TIMER = 0x0113-wm_UNDO = 0x0304-wm_UNICHAR = 0x0109-wm_UNINITMENUPOPUP = 0x0125-wm_UPDATEUISTATE = 0x0128-wm_USER = 0x400-wm_USERCHANGED = 0x0054-wm_VKEYTOITEM = 0x002E-wm_VSCROLL = 0x0115-wm_VSCROLLCLIPBOARD = 0x030A-wm_WINDOWPOSCHANGED = 0x0047-wm_WINDOWPOSCHANGING = 0x0046-wm_WININICHANGE = 0x001A-wm_WTSSESSION_CHANGE = 0x02B1-wm_XBUTTONDBLCLK = 0x020D-wm_XBUTTONDOWN = 0x020B-wm_XBUTTONUP = 0x020C----- Application desktop toolbar ---abm_ACTIVATE = 0x00000006 -- lParam == TRUE/FALSE means activate/deactivate-abm_GETAUTOHIDEBAR = 0x00000007-abm_GETSTATE = 0x00000004-abm_GETTASKBARPOS = 0x00000005-abm_NEW = 0x00000000-abm_QUERYPOS = 0x00000002-abm_REMOVE = 0x00000001-abm_SETAUTOHIDEBAR = 0x00000008 -- This can fail, you MUST check the result-abm_SETPOS = 0x00000003-abm_WINDOWPOSCHANGED = 0x0000009---- Device ---dbt_APPYBEGIN = 0x0000-dbt_APPYEND = 0x0001-dbt_CONFIGCHANGECANCELED = 0x0019-dbt_CONFIGCHANGED = 0x0018-dbt_CONFIGMGAPI32 = 0x0022-dbt_CONFIGMGPRIVATE = 0x7FFF-dbt_CUSTOMEVENT = 0x8006 -- User-defined event-dbt_DEVICEARRIVAL = 0x8000 -- System detected a new device-dbt_DEVICEQUERYREMOVE = 0x8001 -- Wants to remove, may fail-dbt_DEVICEQUERYREMOVEFAILED = 0x8002 -- Removal aborted-dbt_DEVICEREMOVECOMPLETE = 0x8004 -- Device is gone-dbt_DEVICEREMOVEPENDING = 0x8003 -- About to remove, still avail.-dbt_DEVICETYPESPECIFIC = 0x8005 -- Type specific event-dbt_DEVNODES_CHANGED = 0x0007-dbt_DEVTYP_DEVICEINTERFACE = 0x00000005 -- Device interface class-dbt_DEVTYP_DEVNODE = 0x00000001 -- Devnode number-dbt_DEVTYP_HANDLE = 0x00000006 -- File system handle-dbt_DEVTYP_NET = 0x00000004 -- Network resource-dbt_DEVTYP_OEM = 0x00000000 -- Oem-defined device type-dbt_DEVTYP_PORT = 0x00000003 -- Serial, parallel-dbt_DEVTYP_VOLUME = 0x00000002 -- Logical volume-dbt_LOW_DISK_SPACE = 0x0048-dbt_MONITORCHANGE = 0x001B-dbt_NO_DISK_SPACE = 0x0047-dbt_QUERYCHANGECONFIG = 0x0017-dbt_SHELLLOGGEDON = 0x0020-dbt_USERDEFINED = 0xFFFF-dbt_VOLLOCKLOCKFAILED = 0x8043-dbt_VOLLOCKLOCKRELEASED = 0x8045-dbt_VOLLOCKLOCKTAKEN = 0x8042-dbt_VOLLOCKQUERYLOCK = 0x8041-dbt_VOLLOCKQUERYUNLOCK = 0x8044-dbt_VOLLOCKUNLOCKFAILED = 0x8046-dbt_VPOWERDAPI = 0x8100 -- VPOWERD API for Win95-dbt_VXDINITCOMPLETE = 0x0023---- Default push button control ---dm_BITSPERPEL = 0x00040000-dm_COLLATE = 0x00008000-dm_COLOR = 0x00000800-dm_COPIES = 0x00000100-dm_DEFAULTSOURCE = 0x00000200-dm_DISPLAYFLAGS = 0x00200000-dm_DISPLAYFREQUENCY = 0x00400000-dm_DITHERTYPE = 0x04000000-dm_DUPLEX = 0x00001000-dm_FORMNAME = 0x00010000-dm_GRAYSCALE = 0x00000001 -- This flag is no longer valid-dm_ICMINTENT = 0x01000000-dm_ICMMETHOD = 0x00800000-dm_INTERLACED = 0x00000002 -- This flag is no longer valid-dm_LOGPIXELS = 0x00020000-dm_MEDIATYPE = 0x02000000-dm_NUP = 0x00000040-dm_ORIENTATION = 0x00000001-dm_PANNINGHEIGHT = 0x10000000-dm_PANNINGWIDTH = 0x08000000-dm_PAPERLENGTH = 0x00000004-dm_PAPERSIZE = 0x00000002-dm_PAPERWIDTH = 0x00000008-dm_PELSHEIGHT = 0x00100000-dm_PELSWIDTH = 0x00080000-dm_POSITION = 0x00000020-dm_PRINTQUALITY = 0x00000400-dm_SCALE = 0x00000010-dm_SPECVERSION = 0x0320 -- 0x0400 0x0401-dm_TTOPTION = 0x00004000-dm_YRESOLUTION = 0x00002000---- Header control ---hdm_FIRST = 0x1200---- List view control ---lvm_FIRST = 0x1000---- Status bar window ---sb_CONST_ALPHA = 0x00000001-sb_GRAD_RECT = 0x00000010-sb_GRAD_TRI = 0x00000020-sb_NONE = 0x00000000-sb_PIXEL_ALPHA = 0x00000002-sb_PREMULT_ALPHA = 0x00000004-sb_SIMPLEID = 0x00ff---- Scroll bar control ---sbm_ENABLE_ARROWS = 0x00E4 -- Not in win3.1-sbm_GETPOS = 0x00E1 -- Not in win3.1-sbm_GETRANGE = 0x00E3 -- Not in win3.1-sbm_GETSCROLLINFO = 0x00EA-sbm_SETPOS = 0x00E0 -- Not in win3.1-sbm_SETRANGE = 0x00E2 -- Not in win3.1-sbm_SETRANGEREDRAW = 0x00E6 -- Not in win3.1-sbm_SETSCROLLINFO = 0x00E9---- Static control ---stm_GETICON = 0x0171-stm_GETIMAGE = 0x0173-stm_MSGMAX = 0x0174-stm_ONLY_THIS_INTERFACE = 0x00000001-stm_ONLY_THIS_NAME = 0x00000008-stm_ONLY_THIS_PROTOCOL = 0x00000002-stm_ONLY_THIS_TYPE = 0x00000004-stm_SETICON = 0x0170-stm_SETIMAGE = 0x0172---- Tab control ---tcm_FIRST = 0x1300---- Progress bar control ---pbm_SETRANGE = 0x0401-pbm_SETPOS = 0x0402-pbm_DELTAPOS = 0x0403-pbm_SETSTEP = 0x0404-pbm_STEPIT = 0x0405-pbm_GETPOS = 0x0408-pbm_SETMARQUEE = 0x040a
− Development/NSIS/Show.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Development.NSIS.Show(showNSIS) where--import Development.NSIS.Type-import Control.Arrow-import Data.Generics.Uniplate.Data-import Data.Char-import Data.Function-import Data.List-import Data.Maybe---showNSIS :: [NSIS] -> [String]-showNSIS xs =- ["!Include MUI2.nsh"] ++- ["Var _" ++ show v | v <- sort $ nub [i | Var i <- universeBi xs]] ++- outs fs (filter isGlobal xs) ++- ["!insertmacro MUI_LANGUAGE \"English\""] ++- (if null plugins then [] else- ["Function NSIS_UnusedPluginPreload"- ," # Put all plugins are at the start of the archive, ensuring fast extraction (esp. LZMA solid)"] ++- map indent plugins ++- ["FunctionEnd"]) ++- outs fs (filter isSection xs) ++- concat [("Function " ++ show name) : map indent (outs fs body) ++ ["FunctionEnd"] | (name,body) <- funs] ++- (if null descs then [] else- ["!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN"] ++- map indent ["!insertmacro MUI_DESCRIPTION_TEXT " ++ show i ++ " " ++ show d | (i,d) <- descs] ++- ["!insertmacro MUI_FUNCTION_DESCRIPTION_END"])- where descs = filter (not . null . snd) $ concatMap secDescs $ universeBi xs- inits = filter (\x -> not (isSection x) && not (isGlobal x)) xs- fs = map fst funs- funs = map (fst . head &&& concatMap snd) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $- [(Fun ".onInit",inits) | not $ null inits] ++ [(name,body) | Function name body <- universeBi xs]- plugins = sort $ nub [a ++ "::" ++ b | Plugin a b _ <- universeBi xs]---secDescs :: NSIS -> [(SectionId, Val)]-secDescs (Section x _) = [(secId x, secDescription x)]-secDescs (SectionGroup x _) = [(secgId x, secgDescription x)]-secDescs _ = []---isGlobal :: NSIS -> Bool-isGlobal x = case x of- Name{} -> True- OutFile{} -> True- InstallDir{} -> True- SetCompressor{} -> True- InstallIcon{} -> True- UninstallIcon{} -> True- HeaderImage{} -> True- Page{} -> True- Unpage{} -> True- RequestExecutionLevel{} -> True- AddPluginDir{} -> True- InstallDirRegKey{} -> True- AllowRootDirInstall{} -> True- ShowInstDetails{} -> True- ShowUninstDetails{} -> True- Caption{} -> True- Unicode{} -> True- UnsafeInjectGlobal{} -> True- _ -> False--isSection :: NSIS -> Bool-isSection x = case x of- Section{} -> True- SectionGroup{} -> True- _ -> False---outs :: [Fun] -> [NSIS] -> [String]-outs fs = concatMap (out fs)--out :: [Fun] -> NSIS -> [String]-out fs (Assign v x) = ["StrCpy " ++ show v ++ " " ++ show x]-out fs (SetCompressor ACompressor{..}) = [unwords $ "SetCompressor" : ["/solid"|compSolid] ++ ["/final"|compFinal] ++ [map toLower $ show compType]]-out fs (Section ASection{secId=SectionId secId, ..} xs) =- [unwords $ "Section" : ["/o"|secUnselected] ++ [show $ [Literal "!"|secBold] ++ secName, "_sec" ++ show secId]] ++- map indent (["SectionIn RO" | secRequired] ++ outs fs xs) ++- ["SectionEnd"]-out fs (SectionGroup ASectionGroup{secgId=SectionId secgId, ..} xs) =- [unwords $ "SectionGroup" : ["/e"|secgExpanded] ++ [show secgName, "_sec" ++ show secgId]] ++- map indent (outs fs xs) ++- ["SectionGroupEnd"]-out fs (File AFile{..}) = [unwords $ "File" : ["/nonfatal"|fileNonFatal] ++ ["/r"|fileRecursive] ++ [show $ Literal "/oname=" : x | Just x <- [fileOName]] ++ [show filePath]]-out fs (Labeled i) = [show i ++ ":"]-out fs (CreateShortcut AShortcut{..}) = return $ unwords $- ["CreateShortcut", show scFile, show scTarget, show scParameters, show scIconFile- ,show scIconIndex, show scStartOptions, show scKeyboardShortcut, show scDescription]-out fs (InstallIcon x) = ["!define MUI_ICON " ++ show x]-out fs (UninstallIcon x) = ["!define MUI_UNICON " ++ show x]-out fs (HeaderImage x) = "!define MUI_HEADERIMAGE" : ["!define MUI_HEADERIMAGE_BITMAP " ++ show x | Just x <- [x]]-out fs (Page x) = let y = showPageCtor x in- ["!define MUI_PAGE_CUSTOMFUNCTION_PRE Pre" ++ y | "Pre" ++ y `elem` map show fs] ++- ["!define MUI_PAGE_CUSTOMFUNCTION_SHOW Show" ++ y | "Show" ++ y `elem` map show fs] ++- ["!define MUI_PAGE_CUSTOMFUNCTION_LEAVE Leave" ++ y | "Leave" ++ y `elem` map show fs] ++- concat [showFinish x | Finish x <- [x]] ++- ["!insertmacro MUI_PAGE_" ++ showPage x]-out fs (Unpage x) = ["!insertmacro MUI_UNPAGE_" ++ showPage x]-out fs Function{} = []-out fs (Delete ADelete{..}) = [unwords $ "Delete" : ["/rebootok"|delRebootOK] ++ [show delFile]]-out fs (RMDir ARMDir{..}) = [unwords $ "RMDir" : ["/r"|rmRecursive] ++ ["/rebootok"|rmRebootOK] ++ [show rmDir]]-out fs (CopyFiles ACopyFiles{..}) = [unwords $ "CopyFiles" : ["/silent"|cpSilent] ++ ["/filesonly"|cpFilesOnly] ++ [show cpFrom, show cpTo]]-out fs (MessageBox flags txt lbls) = [unwords $ "MessageBox" : intercalate "|" (map show flags) : show txt :- ["ID" ++ a ++ " " ++ show b | (a,b) <- lbls]]-out fs (Goto x) = ["Goto " ++ show x | x /= Label 0]-out fs (IntOp a b "~" _) = [unwords $ "IntOp" : [show a, show b, "~"]] -- the only unary IntOp-out fs (ExecShell AExecShell{..}) = [unwords ["ExecShell","\"\"",show esCommand,show esShow]]-out fs (Plugin a b cs) = [unwords $ (a ++ "::" ++ b) : map show cs]-out fs (AddPluginDir a) = [unwords ["!addplugindir",show a]]-out fs (FindWindow a b c d e) = [unwords $ "FindWindow" : show a : map show ([b,c] ++ maybeToList d ++ maybeToList e)]-out fs (SendMessage a b c d e f) = [unwords $ "SendMessage" : show a : show b : show c : show d : show e : ["/TIMEOUT=" ++ show x | Just x <- [f]]]-out fs (Unicode x) = ["Unicode " ++ if x then "true" else "false"]-out fs (UnsafeInject x) = [x]-out fs (UnsafeInjectGlobal x) = [x]--out fs x = [show x]---showPage :: Page -> String-showPage (License x) = "LICENSE \"" ++ x ++ "\""-showPage x = map toUpper $ showPageCtor x--showFinish :: FinishOptions -> [String]-showFinish FinishOptions{..} =- ["!define MUI_FINISHPAGE_RUN " ++ show finRun | finRun /= def] ++- ["!define MUI_FINISHPAGE_RUN_TEXT " ++ show finRunText | finRunText /= def] ++- ["!define MUI_FINISHPAGE_RUN_PARAMETERS " ++ show finRunParamters | finRunParamters /= def] ++- ["!define MUI_FINISHPAGE_RUN_NOTCHECKED" | not finRunChecked && finRun /= def] ++- ["!define MUI_FINISHPAGE_SHOWREADME " ++ show finReadme | finReadme /= def] ++- ["!define MUI_FINISHPAGE_SHOWREADME_TEXT " ++ show finReadmeText | finReadmeText /= def] ++- ["!define MUI_FINISHPAGE_SHOWREADME_NOTCHECKED" | not finReadmeChecked && finReadme /= def] ++- ["!define MUI_FINISHPAGE_LINK_LOCATION " ++ show finLink | finLink /= def] ++- ["!define MUI_FINISHPAGE_LINK " ++ show finLinkText | finLinkText /= def]---indent x = " " ++ x
− Development/NSIS/Sugar.hs
@@ -1,1164 +0,0 @@-{-# LANGUAGE OverloadedStrings, EmptyDataDecls, ScopedTypeVariables, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- Bits.popCount only introduced in 7.6-{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Applicative and Monoid required < 7.9--module Development.NSIS.Sugar(- Compressor(..), HKEY(..), MessageBoxType(..), Page(..), Level(..), Visibility(..), FileMode(..), SectionFlag(..),- ShowWindow(..), FinishOptions(..), DetailsPrint(..),- module Development.NSIS.Sugar, Label, SectionId- ) where--import Development.NSIS.Type-import Data.Char-import Data.List-import Data.Maybe-import Data.Monoid-import Data.String-import Data.Data-import Data.Bits-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.State-import Data.Generics.Uniplate.Data--------------------------------------------------------------------------- INTERNALS--data S = S- {uniques :: Int- ,stream :: [NSIS]- ,scopes :: [[(String,(TypeRep,Val))]] -- nearest scope is here- }---- | Monad in which installers are defined. A useful command to start with is 'section'.-newtype Action a = Action (State S a)- deriving (Functor, Monad, Applicative)----- | A 'Value', only used by 'Exp', which can be produced using 'return'.--- The @ty@ argument should be one of 'String', 'Int' or 'Bool'.-newtype Value ty = Value {fromValue :: Val}--tyString = typeOf (undefined :: String)-tyInt = typeOf (undefined :: Int)---unique :: Action Int-unique = Action $ do- s <- get- put s{uniques = uniques s + 1}- return $ uniques s--var :: Action Var-var = fmap Var unique--newSectionId :: Action SectionId-newSectionId = fmap SectionId unique--val x = [Var_ x]-lit x = [Literal x | x /= ""]---- | Create a new label, used with 'goto' and 'label' to write line jump based programming.--- Where possible you should use structured alternatives, such as 'iff', 'while' and 'loop'.--- Each created label must be used with one call to 'label', and any number of calls to--- 'goto'. As an example:------ @--- abort <- 'newLabel'--- 'while' var $ do--- 'iff_' cond1 $ 'goto' abort--- 'iff_' cond2 $ 'goto' abort--- var '@=' 'strDrop' 1 var --- 'label' abort--- @------ Note that the above example could have been written in a simpler manner with 'loop'.-newLabel :: Action Label-newLabel = fmap Label unique--emit :: NSIS -> Action ()-emit x = Action $ modify $ \s -> s{stream = stream s ++ [x]}---rval :: Exp a -> Action Var-rval act = do- (xs, res) <- capture act- case res of- _ | not $ null xs -> error $ "An R-value may not emit any statements: " ++ show xs- Value [Var_ x] -> return x- _ -> error $ "An R-value must be a single value, found: " ++ show (fromValue res)---capture :: Action a -> Action ([NSIS], a)-capture (Action act) = Action $ do- s0 <- get- put s0{stream=[]}- res <- act- s1 <- get- put s1{stream=stream s0}- return (stream s1, res)--runAction :: Action () -> [NSIS]-runAction (Action act) = stream $ execState act s0- where s0 = S 1 [] [("NSISDIR",(tyString,[Builtin "{NSISDIR}"])):[(x, (tyString, [Builtin x])) | x <- builtin]]---builtin = words $- "ADMINTOOLS APPDATA CDBURN_AREA CMDLINE COMMONFILES COMMONFILES32 COMMONFILES64 COOKIES DESKTOP DOCUMENTS " ++- "EXEDIR EXEFILE EXEPATH FAVORITES FONTS HISTORY HWNDPARENT INSTDIR INTERNET_CACHE LANGUAGE LOCALAPPDATA " ++- "MUSIC NETHOOD OUTDIR PICTURES PLUGINSDIR PRINTHOOD PROFILE PROGRAMFILES PROGRAMFILES32 PROGRAMFILES64 " ++- "QUICKLAUNCH RECENT RESOURCES RESOURCES_LOCALIZED SENDTO SMPROGRAMS SMSTARTUP STARTMENU SYSDIR TEMP " ++- "TEMPLATES VIDEOS WINDIR"----- | Set all 'file' actions to automatically take 'NonFatal'.-alwaysNonFatal :: Action () -> Action ()-alwaysNonFatal act = do- (xs, _) <- capture act- mapM_ emit $ transformBi f xs- where- f (File x) = File x{fileNonFatal=True}- f x = x----- | The type of expressions - namely an 'Action' producing a 'Value'. There are instances--- for 'Num' and 'IsString', and turning on @{-\# LANGUAGE OverloadedStrings \#-}@ is--- strongly recommended.------ The 'fromString' function converts any embedded @$VAR@ into a variable lookup, which may refer to one of--- the builtin NSIS variables (e.g. @$SMPROGRAMS@, @$TEMP@, @$PROGRAMFILES@), or a named variable--- created with 'constant' or 'mutable'. The string @$$@ is used to escape @$@ values.--- Bracket the variables to put text characters afterwards (e.g. @$(SMPROGRAMS)XXX@). In contrast--- to standard strings, @\/@ is treated as @\\@ and @\/\/@ is treated as @\/@. Remember to escape any--- slashes occuring in URLs.------ If the string is @'Exp' 'String'@ then any 'Int' variables used will be automatically shown (see 'strShow').--- If the string is @'Exp' ty@ then it must be of the form @\"$VAR\"@ where @$VAR@ is a variable of type @ty@.------ The 'Eq' and 'Ord' instances for 'Exp' throw errors for all comparisons (use '%==', '%<=' etc),--- but 'min' and 'max' are defined. The 'Num' (arithmetic) and 'Monoid' (string concatenation) instances are both--- fully implemented. From 'Integral' and 'Fractional', only '/', 'mod' and 'div' are implemented, and--- all as integer arithmetic. No functions from 'Enum' or 'Real' are implemented.------ When using a single expression multiple times, to ensure it is not evaluated--- repeatedly, use 'share'.-type Exp ty = Action (Value ty)--instance forall a . Typeable a => IsString (Exp a) where- fromString o = do- scopes <- Action $ gets scopes- let rty = typeOf (undefined :: a)-- let grab good name = case lookup name $ concat scopes of- Nothing -> error $ "Couldn't find variable, $" ++ name ++ ", in " ++ show o- Just (ty,y)- | ty `notElem` good -> error $ "Type mismatch, $" ++ name ++ " has " ++ show ty ++- ", but you want one of " ++ show good ++ ", in " ++ show o- | otherwise -> y-- -- "$VAR" permits any type, everything else requires string- case parseString o of- [Right var] -> return $ Value $ grab [rty] var- - _ | rty /= tyString ->- error $ "Cannot use concatenated variables/literals to produce anything other than String, but you tried " ++ show rty ++ ", in " ++ show o- xs -> fmap (Value . fromValue) $ strConcat $ flip map xs $ \i -> return $ Value $ case i of- Left x -> lit x- Right name -> grab [tyString,tyInt] name---parseString :: String -> [Either String String]-parseString "" = []-parseString ('/':'/':xs) = Left "/" : parseString xs-parseString ('/':xs) = Left "\\" : parseString xs-parseString ('$':'$':xs) = Left "$" : parseString xs-parseString ('$':'(':xs) = Right a : parseString (drop 1 b)- where (a,b) = break (== ')') xs-parseString ('$':xs) = Right a : parseString b- where (a,b) = span isAlphaNum xs-parseString (x:xs) = Left [x] : parseString xs---instance Show (Exp a) where- show _ = error "show is not available for Exp"--instance Eq (Exp a) where- _ == _ = error "(==) is not available for Exp, try (%==) instead"--instance Num (Exp Int) where- fromInteger = return . Value . lit . show- (+) = intOp "+"- (*) = intOp "*"- (-) = intOp "-"- abs a = share a $ \a -> a %< 0 ? (negate a, a)- signum a = share a $ \a -> a %== 0 ? (0, a %< 0 ? (-1, 1)) --instance Integral (Exp Int) where- mod = intOp "%"- toInteger = error "toInteger is not available for Exp"- div = intOp "/"- quotRem = error "quotRem is not available for Exp"--instance Enum (Exp Int) where- toEnum = error "toEnum is not available for Exp"- fromEnum = error "toEnum is not available for Exp"--instance Real (Exp Int) where- toRational = error "toRational is not available for Exp"--instance Ord (Exp Int) where- compare = error "compare is not available for Exp"- min a b = share a $ \a -> share b $ \b -> a %<= b ? (a, b)- max a b = share a $ \a -> share b $ \b -> a %<= b ? (b, a)--instance Fractional (Exp Int) where- fromRational = error "fromRational is not available for Exp, only Int is supported"- (/) = intOp "/"--instance Monoid (Exp String) where- mempty = fromString ""- mappend x y = mconcat [x,y]- mconcat xs = do- xs <- sequence xs- return $ Value $ f $ concatMap fromValue xs- where- f (Literal "":xs) = f xs- f (Literal x:Literal y:zs) = f $ Literal (x++y) : zs- f (x:xs) = x : f xs- f [] = []--instance Bits (Exp Int) where- (.&.) = intOp "&"- (.|.) = intOp "|"- xor = intOp "^"- complement a = intOp "~" a 0- shiftL a b = intOp "<<" a (fromInteger $ toInteger b)- shiftR a b = intOp ">>" a (fromInteger $ toInteger b)- rotate = error "rotate is not available for Exp"- bitSize = error "bitSize is not available for Exp"- isSigned _ = True- testBit i = error "testBit is not available for Exp"- bit i = fromInteger $ toInteger (bit i :: Int)--intOp :: String -> Exp Int -> Exp Int -> Exp Int-intOp cmd x y = do Value x <- x; Value y <- y; v <- var; emit $ IntOp v x cmd y; return $ Value $ val v--emit1 :: (Val -> NSIS) -> Exp a -> Action ()-emit1 f x1 = do Value x1 <- x1; emit $ f x1--emit2 :: (Val -> Val -> NSIS) -> Exp a -> Exp b -> Action ()-emit2 f x1 x2 = do Value x1 <- x1; Value x2 <- x2; emit $ f x1 x2--emit3 :: (Val -> Val -> Val -> NSIS) -> Exp a -> Exp b -> Exp c -> Action ()-emit3 f x1 x2 x3 = do Value x1 <- x1; Value x2 <- x2; Value x3 <- x3; emit $ f x1 x2 x3---infix 1 @=---- | Assign a value to a mutable variable. The variable must have been originally created with--- 'mutable' or 'mutable_', or there will be an error when generating the install file.-(@=) :: Exp t -> Exp t -> Action ()-(@=) v w = do v <- rval v; Value w <- w; emit $ Assign v w----- | Introduce a variable scope. Scopes are automatically introduced by operations--- such as 'iff', 'loop', 'while' etc. Inside a scope you may define new variables--- whose names may clash with variables outside the scope, but the local versions will be used.------ If you have any non-evaluated expressions, before introducing any potentially clashing--- variables in the scope you should 'share' them or use 'constant_' on them. For example:------ @--- operate x = do--- x <- 'constant_' x--- 'scope' $ do--- 'constant' \"TEST\" 0--- @------ It is important to turn @x@ into a 'constant_' before defining a new constant @$TEST@, since--- if @x@ refers to @$TEST@ after the new definition, it will pick up the wrong variable.-scope :: Action a -> Action a-scope (Action act) = Action $ do- s0 <- get- put s0{scopes=[] : scopes s0}- res <- act- modify $ \s -> s{scopes = scopes s0}- return res---addScope :: forall t . Typeable t => String -> Value t -> Action ()-addScope name v = Action $- modify $ \s -> let now:rest = scopes s in- if name `elem` map fst now- then error $ "Defined twice in one scope, " ++ name- else s{scopes=((name,(typeOf (undefined :: t), fromValue v)):now):rest}- ----- | Create a mutable variable a name, which can be modified with '@='.--- After defining the expression, you can refer to it with @$NAME@ in a 'String'.--- To introduce a new scope, see 'scope'.------ @--- h <- 'mutable' \"HELLO\" \"Hello World\"--- \"$HELLO\" '@=' \"$HELLO!\"--- h '@=' \"$HELLO!\" -- equivalent to the above--- 'alert' \"$HELLO\" -- with 2 exclamation marks--- @-mutable :: Typeable t => String -> Exp t -> Action (Exp t)-mutable name x = do- v <- mutable_ x- vv <- v- addScope name vv- return v---- | Create an unnamed mutable variable, which can be modified with '@='.------ @--- h <- 'mutable' \"Hello World\"--- h '@=' 'h' '&' \"!\"--- 'alert' h--- @-mutable_ :: Exp t -> Action (Exp t)-mutable_ x = do- v <- var- let v2 = return $ Value $ val v- v2 @= x- return v2----- | Create a constant with a name, ensuring the expression is shared.--- After defining the expression, you can refer to it with @$NAME@ in a 'String'.--- To introduce a new scope, see 'scope'.------ @--- 'constant' \"HELLO\" \"Hello World\"--- 'alert' \"$HELLO!\"--- @-constant :: Typeable t => String -> Exp t -> Action (Exp t)-constant name x = do x <- constant_ x; xx <- x; addScope name xx; return x---- | Create a constant with no name, ensuring the expression is shared.--- Equivalent to @'share' 'return'@.-constant_ :: Exp t -> Action (Exp t)-constant_ x = do- -- either the expression is entirely constant, or has mutable variables inside it- Value x <- x- if null [() | Var_{} <- x] then- -- if it's totally constant, we want to leave it that way so it works in non-eval settings (e.g. file)- return $ return $ Value x- else do- -- if it's mutable, we want to share the value, but also snapshot it so that the mutable variables- -- don't change afterwards- v <- var- return (Value $ val v) @= return (Value x)- -- add the Literal so that assignment throws an error in future- return $ return $ Value [Var_ v, Literal ""]----- | The 'Exp' language is call-by-name, meaning you must use share to avoid evaluating an exression--- multiple times. Using 'share', if the expression has any side effects--- they will be run immediately, but not on subsequent uses. When defining functions operating on--- 'Exp', if you use the same input expression twice, you should share it. For example:------ @--- strPalindrom x = 'share' x $ \\x -> x '%==' strReverse x--- @------ If the expression was not shared, and @x@ read from a file, then the file would be read twice.-share :: Exp t -> (Exp t -> Action a) -> Action a-share v act = do v <- constant_ v; act v----- | Versions of 'mutable' and 'constant' restricted to 'Exp' 'Int', used to avoid--- ambiguous type errors.-mutableInt, constantInt :: String -> Exp Int -> Action (Exp Int)-mutableInt = mutable-constantInt = constant---- | Versions of 'mutable_' and 'constant_' restricted to 'Exp' 'Int', used to avoid--- ambiguous type errors.-mutableInt_, constantInt_ :: Exp Int -> Action (Exp Int)-mutableInt_ = mutable_-constantInt_ = constant_---- | Versions of 'mutable' and 'constant' restricted to 'Exp' 'String', used to avoid--- ambiguous type errors.-mutableStr, constantStr :: String -> Exp String -> Action (Exp String)-mutableStr = mutable-constantStr = constant---- | Versions of 'mutable_' and 'constant_' restricted to 'Exp' 'String', used to avoid--- ambiguous type errors.-mutableStr_, constantStr_ :: Exp String -> Action (Exp String)-mutableStr_ = mutable_-constantStr_ = constant_--------------------------------------------------------------------------- EXPRESSION WRAPPERS---- | Perform string concatenation on a list of expressions.-strConcat :: [Exp String] -> Exp String-strConcat = mconcat---- | Boolean negation.-not_ :: Exp Bool -> Exp Bool-not_ a = a ? (false, true)--infix 4 %==, %/=, %<=, %<, %>=, %>---- | The standard equality operators, lifted to 'Exp'.-(%==), (%/=) :: Exp a -> Exp a -> Exp Bool-(%==) a b = do- Value a <- a- Value b <- b- v <- mutable_ false- eq <- newLabel- end <- newLabel- emit $ StrCmpS a b eq end- label eq- v @= true- label end- v--(%/=) a b = not_ (a %== b)---- | The standard comparison operators, lifted to 'Exp'.-(%<=), (%<), (%>=), (%>) :: Exp Int -> Exp Int -> Exp Bool-(%<=) = comp True True False-(%<) = comp False True False-(%>=) = comp True False True-(%>) = comp False False True---comp :: Bool -> Bool -> Bool -> Exp Int -> Exp Int -> Exp Bool-comp eq lt gt a b = do- Value a <- a- Value b <- b- v <- mutable_ false- yes <- newLabel- end <- newLabel- let f b = if b then yes else end- emit $ IntCmp a b (f eq) (f lt) (f gt)- label yes- v @= true- label end- v----- | Boolean constants corresponding to 'True' and 'False'-true, false :: Exp Bool-false = return $ Value []-true = return $ Value [Literal "1"]---- | Lift a 'Bool' into an 'Exp'-bool :: Bool -> Exp Bool-bool x = if x then true else false---- | Lift a 'String' into an 'Exp'-str :: String -> Exp String-str = return . Value . lit---- | Lift an 'Int' into an 'Exp'-int :: Int -> Exp Int-int = return . Value . lit . show---- | Erase the type of an Exp, only useful with 'plugin'.-exp_ :: Exp a -> Exp ()-exp_ = fmap (Value . fromValue)---- | Pop a value off the stack, will set an error if there is nothing on the stack.--- Only useful with 'plugin'.-pop :: Exp String-pop = do v <- var; emit $ Pop v; return $ Value $ val v---- | Push a value onto the stack. Only useful with 'plugin'.-push :: Exp a -> Action ()-push a = do Value a <- a; emit $ Push a---- | Call a plugin. If the arguments are of different types use 'exp_'. As an example:------ @--- encrypt x = 'share' x $ \\x -> do--- 'plugin' \"Base64\" \"Encrypt\" ['exp_' x, 'exp_' $ 'strLength' x]--- @------ The only thing to be careful about is that we use the @x@ parameter twice, so should 'share'--- it to ensure it is only evaluated once.-plugin :: String -> String -> [Exp a] -> Action ()-plugin dll name args = do args <- mapM (fmap fromValue) args; emit $ Plugin dll name args---- | Add a plugin directory-addPluginDir :: Exp String -> Action ()-addPluginDir a = do Value a <- a; emit $ AddPluginDir a----- | Return the length of a string, @strLength \"test\" '%==' 4@.-strLength :: Exp String -> Exp Int-strLength a = do Value a <- a; v <- var; emit $ StrLen v a; return $ Value $ val v---- | Take the first @n@ characters from a string, @strTake 2 \"test\" '%==' \"te\"@.-strTake :: Exp Int -> Exp String -> Exp String-strTake n x = do Value n <- n; Value x <- x; v <- var; emit $ StrCpy v x n (lit ""); return $ Value $ val v---- | Drop the first @n@ characters from a string, @strDrop 2 \"test\" '%==' \"st\"@.-strDrop :: Exp Int -> Exp String -> Exp String-strDrop n x = do Value n <- n; Value x <- x; v <- var; emit $ StrCpy v x (lit "") n; return $ Value $ val v---- | Gets the last write time of the file, you should only use the result to compare for equality--- with other results from 'getFileTime'. On failure the error flag is set.-getFileTime :: Exp FilePath -> Exp String-getFileTime x = do Value x <- x; v1 <- var; v2 <- var; emit $ GetFileTime x v1 v2; strConcat [return $ Value $ val v1, "#", return $ Value $ val v2]--readRegStr :: HKEY -> Exp String -> Exp String -> Exp String-readRegStr k a b = do v <- var; emit2 (ReadRegStr v k) a b; return $ Value $ val v--deleteRegKey :: HKEY -> Exp String -> Action ()-deleteRegKey k = emit1 $ DeleteRegKey k--deleteRegValue :: HKEY -> Exp String -> Exp String -> Action ()-deleteRegValue k = emit2 $ DeleteRegValue k--envVar :: Exp String -> Exp String-envVar a = do v <- var; emit1 (ReadEnvStr v) a; return $ Value $ val v--------------------------------------------------------------------------- ATTRIBUTES--data Attrib- = Solid- | Final- | RebootOK- | Silent- | FilesOnly- | NonFatal- | Recursive- | Unselected- | Expanded- | Description (Exp String)- | Required- | Target (Exp String)- | Parameters (Exp String)- | IconFile (Exp String)- | IconIndex (Exp Int)- | StartOptions String- | KeyboardShortcut String- | Id SectionId- | Timeout Int- | OName (Exp String)- deriving Show--------------------------------------------------------------------------- STATEMENT WRAPPERS---- | Define the location of a 'label', see 'newLabel' for details. This function will fail--- if the same 'Label' is passed to 'label' more than once.-label :: Label -> Action ()-label lbl = emit $ Labeled lbl---- | Jump to a 'label', see 'newLabel' for details. This function will fail--- if 'label' is not used on the 'Label'.-goto :: Label -> Action ()-goto lbl = emit $ Goto lbl---infix 2 ?---- | An expression orientated version of 'iff', returns the first component if--- the first argument is 'true' or the second if it is 'false'.------ @--- x '%==' 12 '?' (x, x '+' 5)--- @-(?) :: Exp Bool -> (Exp t, Exp t) -> Exp t-(?) test (true, false) = do- v <- var- let v2 = return $ Value $ val v- iff test (v2 @= true) (v2 @= false)- v2---- | Test a boolean expression, reunning the first action if it is 'true' and the second if it is 'false'.--- The appropriate branch action will be run within a 'scope'. See '?' for an expression orientated version.------ @--- 'iff' (x '%==' 12) ('alert' \"is 12\") ('alert' \"is not 12\")--- @-iff :: Exp Bool -> Action () -> Action () -> Action ()-iff test true false = do- thn <- newLabel- els <- newLabel- end <- newLabel- Value t <- test- emit $ StrCmpS t (lit "") thn els- label thn- scope false- goto end- label els- scope true- label end----- | A version of 'iff' where there is no else action.-iff_ :: Exp Bool -> Action () -> Action ()-iff_ test true = iff test true (return ())----- | A while loop, run the second argument while the first argument is true.--- The action is run in a 'scope'. See also 'loop'.------ @--- x <- 'mutable_' x--- 'while' (x '%<' 10) $ do--- x '@=' x '+' 1--- @-while :: Exp Bool -> Action () -> Action ()-while test act = do- start <- newLabel- label start- iff_ test (scope act >> goto start)---- | A loop with a @break@ command. Run the action repeatedly until the breaking action--- is called. The action is run in a 'scope'. See also 'while'.------ @--- x <- 'mutable_' x--- 'loop' $ \\break -> do--- 'iff_' (x '%>=' 10) break--- x '@=' x '+' 1--- @-loop :: (Action () -> Action ()) -> Action ()-loop body = do- end <- newLabel- beg <- newLabel- label beg- scope $ body $ goto end- goto beg- label end---- | Run an intitial action, and if that action causes an error, run the second action.--- Unlike other programming languages, any uncaught errors are silently ignored.--- All actions are run in 'scope'.------ @--- 'onError' ('exec' \"\\\"$WINDIR/notepad.exe\\\"\") ('alert' \"Failed to run notepad\")--- @-onError :: Action () -> Action () -> Action ()-onError act catch = do- emit ClearErrors- scope act- end <- newLabel- err <- newLabel- emit $ IfErrors err end- label err- scope catch- label end----- | Checks for existence of file(s) (which can be a wildcard, or a directory).--- If you want to check to see if a file is a directory, use @fileExists "DIRECTORY/*.*"@.------ > iff_ (fileExists "$WINDIR/notepad.exe") $--- > messageBox [MB_OK] "notepad is installed"-fileExists :: Exp FilePath -> Exp Bool-fileExists x = do- v <- mutable_ false- Value x <- x- yes <- newLabel- end <- newLabel- emit $ IfFileExists x yes end- label yes- v @= true- label end- v----- | Performs a search for filespec, running the action with each file found.--- If no files are found the error flag is set. Note that the filename output is without path.------ > findEach "$INSTDIR/*.txt" $ \x ->--- > detailPrint x------ If you jump from inside the loop to after the loop then you may leak a search handle.-findEach :: Exp FilePath -> (Exp FilePath -> Action ()) -> Action ()-findEach spec act = do- Value spec <- spec- hdl <- var- v <- var- emit $ FindFirst hdl v spec- while (return (Value $ val v)) $ do- scope $ act $ return $ Value $ val v- emit $ FindNext (val hdl) v- emit $ FindClose $ val hdl---infixr 5 &---- | Concatenate two strings, for example @\"$FOO\" & \"$BAR\"@ is equivalent--- to @\"$FOO$BAR\"@.-(&) :: Exp String -> Exp String -> Exp String-(&) a b = strConcat [a,b]----- | Convert an 'Int' to a 'String' by showing it.-strShow :: Exp Int -> Exp String-strShow = fmap (Value . fromValue)----- | Convert a 'String' to an 'Int', any errors are silently ignored.-strRead :: Exp String -> Exp Int-strRead = fmap (Value . fromValue)----- | Show an alert, equivalent to @messageBox [MB_ICONEXCLAMATION]@.-alert :: Exp String -> Action ()-alert x = do- _ <- messageBox [MB_ICONEXCLAMATION] x- return ()----------------------------------------------------------------------------- SETTINGS WRAPPERS---- | Sets the name of the installer. The name is usually simply the product name such as \'MyApp\' or \'Company MyApp\'.------ > name "MyApp"-name :: Exp String -> Action ()-name = emit1 Name---- | Specifies the output file that @MakeNSIS@ should write the installer to.--- This is just the file that MakeNSIS writes, it doesn't affect the contents of the installer.--- Usually should end with @.exe@.------ > outFile "installer.exe"-outFile :: Exp FilePath -> Action ()-outFile = emit1 OutFile---- | Sets the output path (@$OUTDIR@) and creates it (recursively if necessary), if it does not exist.--- Must be a full pathname, usually is just @$INSTDIR@.------ > setOutPath "$INSTDIR"-setOutPath :: Exp FilePath -> Action ()-setOutPath = emit1 SetOutPath---- | Sets the default installation directory.--- Note that the part of this string following the last @\\@ will be used if the user selects 'browse', and--- may be appended back on to the string at install time (to disable this, end the directory with a @\\@).--- If this doesn't make any sense, play around with the browse button a bit.------ > installDir "$PROGRAMFILES/MyApp"-installDir :: Exp FilePath -> Action ()-installDir = emit1 InstallDir---- | Writes the uninstaller to the filename (and optionally path) specified.--- Only valid from within an install section, and requires that you have an 'uninstall' section in your script.--- You can call this one or more times to write out one or more copies of the uninstaller.------ > writeUninstaller "$INSTDIR/uninstaller.exe"-writeUninstaller :: Exp FilePath -> Action ()-writeUninstaller = emit1 WriteUninstaller---- | Set the icon used for the installer\/uninstaller.------ > installIcon "$NSISDIR/Contrib/Graphics/Icons/modern-install.ico"-installIcon, uninstallIcon :: Exp FilePath -> Action ()-installIcon = emit1 InstallIcon-uninstallIcon = emit1 UninstallIcon---- | Set the image used for the header splash. Pass 'Nothing' to use the default header image.------ > headerImage $ Just "$NSISDIR/Contrib/Graphics/Header/win.bmp"-headerImage :: Maybe (Exp FilePath) -> Action ()-headerImage Nothing = emit $ HeaderImage Nothing-headerImage (Just x) = emit1 (HeaderImage . Just) x---- | Creates (recursively if necessary) the specified directory. Errors can be caught--- using 'onError'. You should always specify an absolute path.------ > createDirectory "$INSTDIR/some/directory"-createDirectory :: Exp FilePath -> Action ()-createDirectory = emit1 CreateDirectory---- | This attribute tells the installer to check a string in the registry,--- and use it for the install dir if that string is valid. If this attribute is present,--- it will override the 'installDir' attribute if the registry key is valid, otherwise--- it will fall back to the 'installDir' default. When querying the registry, this command--- will automatically remove any quotes. If the string ends in \".exe\", it will automatically--- remove the filename component of the string (i.e. if the string is \"C:/program files/foo/foo.exe\",--- it will know to use \"C:/program files/foo\").------ > installDirRegKey HKLM "Software/NSIS" ""--- > installDirRegKey HKLM "Software/ACME/Thingy" "InstallLocation"-installDirRegKey :: HKEY -> Exp String -> Exp String -> Action ()-installDirRegKey k = emit2 $ InstallDirRegKey k---- | Execute the specified program and continue immediately. Note that the file specified--- must exist on the target system, not the compiling system. @$OUTDIR@ is used for the working--- directory. Errors can be caught using 'onError'. Note, if the command could have spaces,--- you should put it in quotes to delimit it from parameters. e.g.: @exec \"\\\"$INSTDIR/command.exe\\\" parameters\"@.--- If you don't put it in quotes it will not work on Windows 9x with or without parameters.------ > exec "\"$INSTDIR/someprogram.exe\""--- > exec "\"$INSTDIR/someprogram.exe\" some parameters"-exec :: Exp String -> Action ()-exec = emit1 Exec--execWait :: Exp String -> Action ()-execWait = emit1 ExecWait--execShell :: [ShowWindow] -> Exp String -> Action ()-execShell sw x = do- Value x <- x- let d = def{esCommand=x}- emit $ ExecShell $ if null sw then d else d{esShow=last sw}--sectionSetText :: SectionId -> Exp String -> Action ()-sectionSetText x = emit1 $ SectionSetText x--sectionGetText :: SectionId -> Exp String-sectionGetText x = do v <- var; emit $ SectionGetText x v; return $ Value $ val v--data SectionFlag- = SF_Selected- | SF_SectionGroup- | SF_SectionGroupEnd- | SF_Bold- | SF_ReadOnly- | SF_Expand- | SF_PartiallySelected- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)--sectionGet :: SectionId -> SectionFlag -> Exp Bool-sectionGet sec flag = do- v <- var- emit $ SectionGetFlags sec v- let b = bit $ fromEnum flag :: Exp Int- b %== (return (Value $ val v) .&. b)--sectionSet :: SectionId -> SectionFlag -> Exp Bool -> Action ()-sectionSet sec flag set = do- v <- var- emit $ SectionGetFlags sec v- v <- return (return $ Value $ val v :: Exp Int)- iff set- (emit1 (SectionSetFlags sec) $ setBit v (fromEnum flag))- (emit1 (SectionSetFlags sec) $ clearBit v (fromEnum flag))----- don't want to accidentally dupe the message box, so make it in Action Exp-messageBox :: [MessageBoxType] -> Exp String -> Action (Exp String)-messageBox ty x = do- let a*b = (a, words b)- let alts = [MB_OK * "OK"- ,MB_OKCANCEL * "OK CANCEL"- ,MB_ABORTRETRYIGNORE * "ABORT RETRY IGNORE"- ,MB_RETRYCANCEL * "RETRY CANCEL"- ,MB_YESNO * "YES NO"- ,MB_YESNOCANCEL * "YES NO CANCEL"]- let (btns,rest) = partition (`elem` map fst alts) ty- let btn = last $ MB_OK : btns- let alt = fromJust $ lookup btn alts-- end <- newLabel- lbls <- replicateM (length alt) newLabel- v <- mutable_ ""- Value x <- x- emit $ MessageBox (btn:rest) x $ zip alt lbls- forM_ (zip alt lbls) $ \(a,l) -> do- label l- v @= fromString a- goto end- label end- return v--writeRegStr :: HKEY -> Exp String -> Exp String -> Exp String -> Action ()-writeRegStr k = emit3 $ WriteRegStr k--writeRegExpandStr :: HKEY -> Exp String -> Exp String -> Exp String -> Action ()-writeRegExpandStr k = emit3 $ WriteRegExpandStr k--writeRegDWORD :: HKEY -> Exp String -> Exp String -> Exp Int -> Action ()-writeRegDWORD k = emit3 $ WriteRegDWORD k---- | While the action is executing, do not update the progress bar.--- Useful for functions which do a large amount of computation, or have loops.-hideProgress :: Action a -> Action a-hideProgress act = do- fun <- fmap newFun unique- (xs, v) <- capture act- emit $ Function fun xs- emit $ Call fun- return v---- | Sleep time in milliseconds-sleep :: Exp Int -> Action ()-sleep = emit1 Sleep---- | Create a function, useful for registering actions-event :: String -> Action () -> Action ()-event name act = do- (xs, _) <- capture act- emit $ Function (Fun name) xs--onSelChange :: Action () -> Action ()-onSelChange = event ".onSelChange"--onPageShow, onPagePre, onPageLeave :: Page -> Action () -> Action ()--- these names are special and bound by Show-onPageShow p = event $ "Show" ++ showPageCtor p-onPagePre p = event $ "Pre" ++ showPageCtor p-onPageLeave p = event $ "Show" ++ showPageCtor p--allowRootDirInstall :: Bool -> Action ()-allowRootDirInstall = emit . AllowRootDirInstall--caption :: Exp String -> Action ()-caption = emit1 Caption--detailPrint :: Exp String -> Action ()-detailPrint = emit1 DetailPrint--setDetailsPrint :: DetailsPrint -> Action ()-setDetailsPrint = emit . SetDetailsPrint--showInstDetails :: Visibility -> Action ()-showInstDetails = emit . ShowInstDetails--showUninstDetails :: Visibility -> Action ()-showUninstDetails = emit . ShowUninstDetails---- | Note: Requires NSIS 3.0-unicode :: Bool -> Action ()-unicode = emit . Unicode---- | The type of a file handle, created by 'fileOpen'.-data FileHandle deriving Typeable---- | Open a file, which must be closed explicitly with 'fileClose'.--- Often it is better to use 'Development.NSIS.Sugar.writeFile'' or--- 'Development.NSIS.Sugar.withFile' instead.------ @--- h <- 'fileOpen' 'ModeWrite' \"C:/log.txt\"--- 'fileWrite' h \"Hello world!\"--- 'fileClose' h--- @-fileOpen :: FileMode -> Exp FilePath -> Action (Exp FileHandle)-fileOpen mode name = do- Value name <- name- v <- var- emit $ FileOpen v name mode- return $ return $ Value $ val v---- | Write a string to a file openned with 'fileOpen'.-fileWrite :: Exp FileHandle -> Exp String -> Action ()-fileWrite = emit2 FileWrite---- | Close a file file openned with 'fileOpen'.-fileClose :: Exp FileHandle -> Action ()-fileClose = emit1 FileClose--setCompressor :: Compressor -> [Attrib] -> Action ()-setCompressor x as = emit $ SetCompressor $ foldl f def{compType=x} as- where- f c Final = c{compFinal=True}- f c Solid = c{compSolid=True}- f c x = error $ "Invalid attribute to setCompress: " ++ show x--file :: [Attrib] -> Exp FilePath -> Action ()-file as x = do Value x <- x; emit . File =<< foldM f def{filePath=x} as- where- f c Recursive = return c{fileRecursive=True}- f c NonFatal = return c{fileNonFatal=True}- f c (OName x) = do Value x <- x; return c{fileOName=Just x}- f c x = error $ "Invalid attribute to file: " ++ show x--section :: Exp String -> [Attrib] -> Action () -> Action SectionId-section name as act = do- sec <- newSectionId- Value name <- name- (xs, _) <- capture $ scope act- x <- foldM f def{secId=sec, secName=name} as- emit $ Section x xs- return $ secId x- where- f c Unselected = return c{secUnselected=True}- f c Required = return c{secRequired=True}- f c (Description x) = do Value x <- x; return c{secDescription=x}- f c (Id x) = return c{secId=x}- f c x = error $ "Invalid attribute to section: " ++ show x--sectionGroup :: Exp String -> [Attrib] -> Action () -> Action SectionId-sectionGroup name as act = do- sec <- newSectionId- Value name <- name- (xs, _) <- capture $ scope act- x <- foldM f def{secgId=sec, secgName=name} as- emit $ SectionGroup x xs- return $ secgId x- where- f c Expanded = return c{secgExpanded=True}- f c (Description x) = do Value x <- x; return c{secgDescription=x}- f c (Id x) = return c{secgId=x}- f c x = error $ "Invalid attribute to sectionGroup: " ++ show x--uninstall :: Action () -> Action ()-uninstall = void . section "Uninstall" []---- | Delete file (which can be a file or wildcard, but should be specified with a full path) from the target system.--- If 'RebootOK' is specified and the file cannot be deleted then the file is deleted when the system reboots ----- if the file will be deleted on a reboot, the reboot flag will be set. The error flag is set if files are found--- and cannot be deleted. The error flag is not set from trying to delete a file that does not exist.------ > delete [] "$INSTDIR/somefile.dat"-delete :: [Attrib] -> Exp FilePath -> Action ()-delete as x = do- Value x <- x- emit $ Delete $ foldl f def{delFile=x} as- where- f c RebootOK = c{delRebootOK=True}- f c x = error $ "Invalid attribute to delete: " ++ show x---- | Remove the specified directory (fully qualified path with no wildcards). Without 'Recursive',--- the directory will only be removed if it is completely empty. If 'Recursive' is specified, the--- directory will be removed recursively, so all directories and files in the specified directory--- will be removed. If 'RebootOK' is specified, any file or directory which could not have been--- removed during the process will be removed on reboot -- if any file or directory will be--- removed on a reboot, the reboot flag will be set.--- The error flag is set if any file or directory cannot be removed.------ > rmdir [] "$INSTDIR"--- > rmdir [] "$INSTDIR/data"--- > rmdir [Recursive, RebootOK] "$INSTDIR"--- > rmdir [RebootOK] "$INSTDIR/DLLs"------ Note that the current working directory can not be deleted. The current working directory is--- set by 'setOutPath'. For example, the following example will not delete the directory.------ > setOutPath "$TEMP/dir"--- > rmdir [] "$TEMP/dir"------ The next example will succeed in deleting the directory.------ > setOutPath "$TEMP/dir"--- > setOutPath "$TEMP"--- > rmdir [] "$TEMP/dir"------ Warning: using @rmdir [Recursive] "$INSTDIR"@ in 'uninstall' is not safe. Though it is unlikely,--- the user might select to install to the Program Files folder and so this command will wipe out--- the entire Program Files folder, including other programs that has nothing to do with the uninstaller.--- The user can also put other files but the program's files and would expect them to get deleted with--- the program. Solutions are available for easily uninstalling only files which were installed by the installer.-rmdir :: [Attrib] -> Exp FilePath -> Action ()-rmdir as x = do- Value x <- x- emit $ RMDir $ foldl f def{rmDir=x} as- where- f c RebootOK = c{rmRebootOK=True}- f c Recursive = c{rmRecursive=True}- f c x = error $ "Invalid attribute to rmdir: " ++ show x---- | Both file paths are on the installing system. Do not use relative paths.-copyFiles :: [Attrib] -> Exp FilePath -> Exp FilePath -> Action ()-copyFiles as from to = do- Value from <- from- Value to <- to- emit $ CopyFiles $ foldl f def{cpFrom=from, cpTo=to} as- where- f c Silent = c{cpSilent=True}- f c FilesOnly = c{cpFilesOnly=True}- f c x = error $ "Invalid attribute to copyFiles: " ++ show x---- | Creates a shortcut file that links to a 'Traget' file, with optional 'Parameters'. The icon used for the shortcut--- is 'IconFile','IconIndex'. 'StartOptions' should be one of: SW_SHOWNORMAL, SW_SHOWMAXIMIZED, SW_SHOWMINIMIZED.--- 'KeyboardShortcut' should be in the form of 'flag|c' where flag can be a combination (using |) of: ALT, CONTROL, EXT, or SHIFT.--- c is the character to use (a-z, A-Z, 0-9, F1-F24, etc). Note that no spaces are allowed in this string. A good example is--- \"ALT|CONTROL|F8\". @$OUTDIR@ is used for the working directory. You can change it by using 'setOutPath' before creating--- the Shortcut. 'Description' should be the description of the shortcut, or comment as it is called under XP.--- The error flag is set if the shortcut cannot be created (i.e. either of the paths (link or target) does not exist, or some other error).------ > createDirectory "$SMPROGRAMS/My Company"--- > createShortcut "$SMPROGRAMS/My Company/My Program.lnk"--- > [Target "$INSTDIR/My Program.exe"--- > ,Parameters "some command line parameters"--- > ,IconFile "$INSTDIR/My Program.exe", IconIndex 2--- > ,StartOptions "SW_SHOWNORMAL"--- > ,KeyboardShortcut "ALT|CONTROL|SHIFT|F5"--- > ,Description "a description"]-createShortcut :: Exp FilePath -> [Attrib] -> Action ()-createShortcut name as = do Value name <- name; x <- foldM f def{scFile=name} as; emit $ CreateShortcut x- where- f c (Target x) = do Value x <- x; return c{scTarget=x}- f c (Parameters x) = do Value x <- x; return c{scParameters=x}- f c (IconFile x) = do Value x <- x; return c{scIconFile=x}- f c (IconIndex x) = do Value x <- x; return c{scIconIndex=x}- f c (StartOptions x) = return c{scStartOptions=x}- f c (KeyboardShortcut x) = return c{scKeyboardShortcut=x}- f c (Description x) = do Value x <- x; return c{scDescription=x}- f c x = error $ "Invalid attribute to shortcut: " ++ show x---page :: Page -> Action ()-page = emit . Page--finishOptions :: FinishOptions-finishOptions = def--unpage :: Page -> Action ()-unpage = emit . Unpage--requestExecutionLevel :: Level -> Action ()-requestExecutionLevel = emit . RequestExecutionLevel--type HWND = Exp Int--hwndParent :: HWND-hwndParent = return $ Value [Builtin "HWNDPARENT"]--findWindow :: Exp String -> Exp String -> Maybe HWND -> Action HWND-findWindow a b c = do- v <- var- Value a <- a- Value b <- b- c <- maybe (return Nothing) (fmap (Just . fromValue)) c- emit $ FindWindow v a b c Nothing- return $ return $ Value $ val v--getDlgItem :: HWND -> Exp Int -> Action HWND-getDlgItem a b = do- v <- var- Value a <- a- Value b <- b- emit $ GetDlgItem v a b- return $ return $ Value $ val v--sendMessage :: [Attrib] -> HWND -> Exp Int -> Exp a -> Exp b -> Action (Exp Int)-sendMessage as a b c d = do- v <- var- Value a <- a- Value b <- b- Value c <- c- Value d <- d- as <- return $ foldl f Nothing as- emit $ SendMessage a b c d v as- return $ return $ Value $ val v- where- f c (Timeout x) = Just x- f c x = error $ "Invalid attribute to sendMessage: " ++ show x--abort :: Exp String -> Action ()-abort = emit1 Abort---- | Inject arbitrary text into a non-global section of the script.-unsafeInject :: String -> Action ()-unsafeInject = emit . UnsafeInject---- | Inject arbitrary text into the script's global header section.-unsafeInjectGlobal :: String -> Action ()-unsafeInjectGlobal = emit . UnsafeInjectGlobal
− Development/NSIS/Type.hs
@@ -1,326 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Development.NSIS.Type where--import Data.Data--class Default a where def :: a-instance Default (Maybe a) where def = Nothing-instance Default [a] where def = []---newtype Var = Var Int deriving (Data,Typeable,Eq)-instance Default Var where def = Var 0-instance Show Var where show (Var i) = "$_" ++ show i----- | A code label, used for @goto@ programming, see 'Development.NSIS.Sugar.newLabel'.-newtype Label = Label Int deriving (Data,Typeable,Eq)-instance Show Label where show (Label i) = if i == 0 then "0" else "_lbl" ++ show i---newtype Fun = Fun String deriving (Data,Typeable,Eq,Ord)-instance Show Fun where show (Fun i) = i--newFun :: Int -> Fun-newFun i = Fun $ "_fun" ++ show i--newtype SectionId = SectionId Int deriving (Data,Typeable)-instance Show SectionId where show (SectionId i) = "${_sec" ++ show i ++ "}"---type Val = [Val_]-data Val_ = Var_ Var | Builtin String | Literal String deriving (Data,Typeable,Eq)--instance Show Val_ where- show x = show [x]- showList xs = showString $ "\"" ++ concatMap f xs ++ "\""- where- f (Var_ x) = show x- f (Builtin x) = "$" ++ x- f (Literal x) = concatMap g x-- g '\"' = "$\\\""- g '\r' = "$\\r"- g '\n' = "$\\n"- g '\t' = "$\\t"- g '$' = "$$"- g x = [x]---data NSIS- -- primitives- = Assign Var Val- | Goto Label- | Labeled Label-- -- functions and branches- | StrCmpS Val Val Label Label- | IntCmp Val Val Label Label Label- | IntOp Var Val String Val- | StrCpy Var Val Val Val- | StrLen Var Val- | GetFileTime Val Var Var- | IfErrors Label Label- | SectionGetText SectionId Var- | SectionSetText SectionId Val- | SectionGetFlags SectionId Var- | SectionSetFlags SectionId Val- | IfFileExists Val Label Label- | FindFirst Var Var Val- | FindNext Val Var- | FindClose Val- | Push Val- | Pop Var-- -- blocks- | Section ASection [NSIS]- | SectionGroup ASectionGroup [NSIS]- | Function Fun [NSIS]- | Call Fun-- -- Global settings- | Name Val- | File AFile- | OutFile Val- | InstallDir Val- | InstallIcon Val- | UninstallIcon Val- | HeaderImage (Maybe Val)- | Page Page- | Unpage Page-- -- Actions- | SetOutPath Val- | CreateDirectory Val- | SetCompressor ACompressor- | WriteUninstaller Val- | FileOpen Var Val FileMode- | FileWrite Val Val- | FileClose Val- | MessageBox [MessageBoxType] Val [(String,Label)]- | CreateShortcut AShortcut- | WriteRegStr HKEY Val Val Val- | WriteRegExpandStr HKEY Val Val Val- | WriteRegDWORD HKEY Val Val Val- | ReadRegStr Var HKEY Val Val- | DeleteRegKey HKEY Val- | DeleteRegValue HKEY Val Val- | ReadEnvStr Var Val- | Exec Val- | ExecWait Val- | ExecShell AExecShell- | ClearErrors- | Delete ADelete- | RMDir ARMDir- | CopyFiles ACopyFiles- | RequestExecutionLevel Level- | AddPluginDir Val- | InstallDirRegKey HKEY Val Val- | AllowRootDirInstall Bool- | Caption Val- | ShowInstDetails Visibility- | ShowUninstDetails Visibility- | Unicode Bool- | SetDetailsPrint DetailsPrint- | DetailPrint Val- | Plugin String String [Val]- | Sleep Val- | FindWindow Var Val Val (Maybe Val) (Maybe Val)- | GetDlgItem Var Val Val- | SendMessage Val Val Val Val Var (Maybe Int)- | Abort Val-- -- Escape hatch- | UnsafeInject String- | UnsafeInjectGlobal String- deriving (Data,Typeable,Show)---- | Value to use with 'setDetailsPrint'.-data DetailsPrint = NoDetailsPrint | ListOnly | TextOnly | Both | LastUsed- deriving (Data,Typeable,Bounded,Enum,Eq,Ord)--instance Show DetailsPrint where- show NoDetailsPrint = "None"- show ListOnly = "ListOnly"- show TextOnly = "TextOnly"- show Both = "Both"- show LastUsed = "LastUsed"---- | Mode to use with 'Development.-data FileMode- = ModeRead -- ^ Read a file.- | ModeWrite -- All contents of file are destroyed.- | ModeAppend -- ^ Opened for both read and write, contents preserved.- deriving (Data,Typeable,Bounded,Enum,Eq,Ord)- -instance Show FileMode where- show ModeRead = "r"- show ModeWrite = "w"- show ModeAppend = "a"---data AShortcut = AShortcut- {scFile :: Val- ,scTarget :: Val- ,scParameters :: Val- ,scIconFile :: Val- ,scIconIndex :: Val- ,scStartOptions :: String- ,scKeyboardShortcut :: String- ,scDescription :: Val- } deriving (Data,Typeable,Show)--instance Default AShortcut where def = AShortcut def def def def def def def def--data ASection = ASection- {secId :: SectionId- ,secName :: Val- ,secDescription :: Val- ,secBold :: Bool- ,secRequired :: Bool- ,secUnselected :: Bool- } deriving (Data,Typeable,Show)--instance Default ASection where def = ASection (SectionId 0) def def False False False--data ASectionGroup = ASectionGroup- {secgId :: SectionId- ,secgName :: Val- ,secgExpanded :: Bool- ,secgDescription :: Val- } deriving (Data,Typeable,Show)--instance Default ASectionGroup where def = ASectionGroup (SectionId 0) def False def--data Compressor = LZMA | ZLIB | BZIP2 deriving (Data,Typeable,Show)--instance Default Compressor where def = ZLIB--data ACompressor = ACompressor - {compType :: Compressor- ,compSolid :: Bool- ,compFinal :: Bool- } deriving (Data,Typeable,Show)--instance Default ACompressor where def = ACompressor def False False--data AFile = AFile- {filePath :: Val- ,fileNonFatal :: Bool- ,fileRecursive :: Bool- ,fileOName :: Maybe Val- } deriving (Data,Typeable,Show)--instance Default AFile where def = AFile def False False Nothing--data ARMDir = ARMDir- {rmDir :: Val- ,rmRecursive :: Bool- ,rmRebootOK :: Bool- } deriving (Data,Typeable,Show)--instance Default ARMDir where def = ARMDir def False False--data ADelete = ADelete- {delFile :: Val- ,delRebootOK :: Bool- } deriving (Data,Typeable,Show)--instance Default ADelete where def = ADelete def False--data AExecShell = AExecShell- {esCommand :: Val- ,esShow :: ShowWindow- } deriving (Data,Typeable,Show)--instance Default AExecShell where def = AExecShell def def--data ACopyFiles = ACopyFiles- {cpFrom :: Val- ,cpTo :: Val- ,cpSilent :: Bool- ,cpFilesOnly :: Bool- } deriving (Data,Typeable,Show)--instance Default ACopyFiles where def = ACopyFiles def def False False--data ShowWindow- = SW_SHOWDEFAULT- | SW_SHOWNORMAL- | SW_SHOWMAXIMIZED- | SW_SHOWMINIMIZED- | SW_HIDE- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)--instance Default ShowWindow where def = SW_SHOWDEFAULT--data HKEY- = HKCR | HKEY_CLASSES_ROOT- | HKLM | HKEY_LOCAL_MACHINE- | HKCU | HKEY_CURRENT_USER- | HKU | HKEY_USERS- | HKCC | HKEY_CURRENT_CONFIG- | HKDD | HKEY_DYN_DATA- | HKPD | HKEY_PERFORMANCE_DATA- | SHCTX | SHELL_CONTEXT- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)--data MessageBoxType- = MB_OK -- ^ Display with an OK button- | MB_OKCANCEL -- ^ Display with an OK and a cancel button- | MB_ABORTRETRYIGNORE -- ^ Display with abort, retry, ignore buttons- | MB_RETRYCANCEL -- ^ Display with retry and cancel buttons- | MB_YESNO -- ^ Display with yes and no buttons- | MB_YESNOCANCEL -- ^ Display with yes, no, cancel buttons- | MB_ICONEXCLAMATION -- ^ Display with exclamation icon- | MB_ICONINFORMATION -- ^ Display with information icon- | MB_ICONQUESTION -- ^ Display with question mark icon- | MB_ICONSTOP -- ^ Display with stop icon- | MB_USERICON -- ^ Display with installer's icon- | MB_TOPMOST -- ^ Make messagebox topmost- | MB_SETFOREGROUND -- ^ Set foreground- | MB_RIGHT -- ^ Right align text- | MB_RTLREADING -- ^ RTL reading order- | MB_DEFBUTTON1 -- ^ Button 1 is default- | MB_DEFBUTTON2 -- ^ Button 2 is default- | MB_DEFBUTTON3 -- ^ Button 3 is default- | MB_DEFBUTTON4 -- ^ Button 4 is default- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)-instance Default MessageBoxType where def = MB_ICONINFORMATION---data Page- = License FilePath- | Components- | Directory- | InstFiles- | Confirm- | Finish FinishOptions- deriving (Show,Data,Typeable,Eq)--data FinishOptions = FinishOptions- {finRun :: String- ,finRunText :: String- ,finRunParamters :: String- ,finRunChecked :: Bool- ,finReadme :: String- ,finReadmeText :: String- ,finReadmeChecked :: Bool- ,finLink :: String- ,finLinkText :: String- } deriving (Data,Typeable,Show,Eq)--instance Default FinishOptions where def = FinishOptions "" "" "" True "" "" True "" ""---showPageCtor :: Page -> String-showPageCtor (License _) = "License"-showPageCtor (Finish _) = "Finish"-showPageCtor x = show x--data Level = None | User | Highest | Admin- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)--data Visibility = Hide | Show | NeverShow- deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)
− Examples/Base64.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Base64(base64) where--import Development.NSIS-import Development.NSIS.Plugins.Base64---base64 = do- name "base64"- allowRootDirInstall True- outFile "base64.exe"- caption "Base64 test"- showInstDetails Show- installDir "$EXEDIR"- requestExecutionLevel User- addPluginDir "."-- page Directory- page InstFiles-- section "" [] $ do- setOutPath "$INSTDIR"- let src = "Hello NSIS Plugin!"- enc <- constant_ $ encrypt src- dec <- constant_ $ decrypt enc- alert $ "Source: " & src & "\nEncrypted: " & enc & "\nDecrypted: " & dec
− Examples/EnvVarUpdate.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.EnvVarUpdate(envvarupdate) where--import Development.NSIS-import Development.NSIS.Plugins.EnvVarUpdate---envvarupdate = do- name "envvarupdate"- outFile "envvarupdate.exe"- requestExecutionLevel User-- section "" [] $ do- let assert x = iff_ (getEnvVar HKCU "NSIS_TEST" %/= x) $ alert $ "FAILED!"- deleteEnvVar HKCU "NSIS_TEST"- setEnvVar HKCU "NSIS_TEST" "This is a;test"- assert "This is a;test"- setEnvVarAppend HKCU "NSIS_TEST" "foo bar"- assert "This is a;test;foo bar"- setEnvVarPrepend HKCU "NSIS_TEST" "test"- assert "test;This is a;foo bar"- setEnvVarRemove HKCU "NSIS_TEST" "test"- assert "This is a;foo bar"- setEnvVarRemove HKCU "NSIS_TEST" "foo bar"- assert "This is a"- setEnvVarPrepend HKCU "NSIS_TEST" "extra"- assert "extra;This is a"- setEnvVarRemove HKCU "NSIS_TEST" "bob"- assert "extra;This is a"- setEnvVar HKCU "NSIS_TEST" "bob;bob;bob;x;bob"- setEnvVarRemove HKCU "NSIS_TEST" "bob"- assert "x"- setEnvVarRemove HKCU "NSIS_TEST" "x"- assert ""- setEnvVar HKCU "NSIS_TEST" "y"- deleteEnvVar HKCU "NSIS_TEST"- assert ""-- alert $ "USER $$PATH = " & getEnvVar HKCU "PATH"- alert $ "MACHINE $$PATH = " & getEnvVar HKLM "PATH"-- alert "Expecting to abort with a String limit error"- deleteEnvVar HKCU "NSIS_TEST"- val <- mutable_ "This is a test that will overflow at some point"- i <- mutable_ 0- while (i %< 100) $ do- i @= i + 1- val @= val & val- setEnvVar HKCU "NSIS_TEST" val- alert "Failed test, should have got a string limit error"
− Examples/Example1.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Example1(example1) where--import Development.NSIS----- Based on example1.nsi from NSIS------ This script is perhaps one of the simplest NSIs you can make. All of the--- optional settings are left to their default settings. The installer simply --- prompts the user asking them where to install, and drops a copy of example1.hs--- there. -example1 = do- - -- The name of the installer- name "Example1"-- -- The file to write- outFile "example1.exe"-- -- The default installation directory- installDir "$DESKTOP/Example1"-- -- Request application privileges for Windows Vista- requestExecutionLevel User-- ----------------------------------- -- Pages- - page Directory- page InstFiles-- ----------------------------------- -- The stuff to install- section "" [] $ do -- No components page, name is not important-- -- Set output path to the installation directory.- setOutPath "$INSTDIR"-- -- Put file there- file [] "Examples/Example1.hs"
− Examples/Example2.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Example2(example2) where--import Development.NSIS---- Based on example2.nsi from NSIS------ This script is based on example1.nsi, but it remember the directory, --- has uninstall support and (optionally) installs start menu shortcuts.------ It will install example2.nsi into a directory that the user selects,--------------------------------------example2 = do- -- The name of the installer- _ <- constantStr "Ex" "2"-- name "Example$Ex"-- -- The file to write- outFile "example$Ex.exe"-- -- The default installation directory- installDir "$PROGRAMFILES64/Example2"-- -- Registry key to check for directory (so if you install again, it will - -- overwrite the old one automatically)- installDirRegKey HKLM "Software/NSIS_Example2" "Install_Dir"-- -- Request application privileges for Windows Vista- requestExecutionLevel Admin-- -- Inject a literal setting that's not currently supported by the DSL- unsafeInjectGlobal "# ignore me (could be an injected literal)"-- ------------------------------------ -- Pages-- page Components- page Directory- page InstFiles-- unpage Confirm- unpage InstFiles-- ------------------------------------ -- The stuff to install- section "Example2 (required)" [Required] $ do-- -- Set output path to the installation directory.- setOutPath "$INSTDIR"-- -- Put file there- file [] "Examples/Example$Ex.hs"-- -- Inject a non-global literal setting- unsafeInject "# ignore me (could be an injected literal)"-- -- Write the installation path into the registry- writeRegStr HKLM "SOFTWARE/NSIS_Example2" "Install_Dir" "$INSTDIR"-- -- Write the uninstall keys for Windows- writeRegStr HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "DisplayName" "NSIS Example2"- writeRegStr HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "UninstallString" "\"$INSTDIR/uninstall.exe\""- writeRegDWORD HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "NoModify" 1- writeRegDWORD HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "NoRepair" 1- writeUninstaller "uninstall.exe"-- -- Optional section (can be disabled by the user)- section "Start Menu Shortcuts" [] $ do-- createDirectory "$SMPROGRAMS/Example2"- createShortcut "$SMPROGRAMS/Example2/Uninstall.lnk" [Target "$INSTDIR/uninstall.exe", IconFile "$INSTDIR/uninstall.exe", IconIndex 0]- createShortcut "$SMPROGRAMS/Example2/Example2 (MakeNSISW).lnk" [Target "$INSTDIR/example2.nsi", IconFile "$INSTDIR/example2.nsi", IconIndex 0]-- ------------------------------------ -- Uninstaller-- uninstall $ do-- -- Remove registry keys- deleteRegKey HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2"- deleteRegKey HKLM "SOFTWARE/NSIS_Example2"-- -- Remove files and uninstaller- delete [] "$INSTDIR/example2.nsi"- delete [] "$INSTDIR/uninstall.exe"-- -- Remove shortcuts, if any- delete [] "$SMPROGRAMS/Example2/*.*"-- -- Remove directories used- rmdir [] "$SMPROGRAMS/Example2"- rmdir [] "$INSTDIR"
− Examples/Finish.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Finish(finish) where--import Development.NSIS---finish = do- name "Finish"- outFile "finish.exe"- requestExecutionLevel User- installDir "$DESKTOP"-- page Directory- page InstFiles- page $ Finish finishOptions- {finRun="$WINDIR/notepad.exe"- ,finRunText="Run Notepad"- ,finLink="http://google.com/"- ,finLinkText="Visit Google!"- }-- section "" [] $ return ()
− Examples/Primes.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Primes(primes) where--import Development.NSIS---- Based on primes.nsi from NSIS------ This is an example of the possibities of the NSIS Script language.--- It calculates prime numbers.--------------------------------------primes = do-- name "primes"- allowRootDirInstall True- outFile "primes.exe"- caption "Prime number generator"- showInstDetails Show- installDir "$EXEDIR"- requestExecutionLevel User-- ------------------------------------ --Pages-- page Directory- page InstFiles-- ------------------------------------ section "" [] $ do- setOutPath "$INSTDIR"- hideProgress doPrimes---doPrimes = do- hdl <- fileOpen ModeWrite "$INSTDIR/primes.txt"-- let output x = do- detailPrint $ strShow x & " is prime!"- fileWrite hdl $ strShow x & " is prime!\r\n"- output 2- output 3-- ppos <- mutableInt "PPOS" 5 -- position in prime searching- pdiv <- mutableInt "PDIV" 0 -- divisor- pcnt <- mutableInt "PCNT" 2 -- count of how many we've printed- loop $ \breakOuter -> do- pdiv @= 3- loop $ \breakInner -> do- iff_ (ppos `mod` pdiv %== 0) $ do- ppos @= ppos + 2- breakInner- pdiv @= pdiv + 2- iff_ (pdiv %>= ppos) $ do- output ppos- pcnt @= pcnt + 1- iff_ (pcnt %== 100) $ do- pcnt @= 0- ans <- messageBox [MB_YESNO] "Process more?"- iff_ (ans %== "NO")- breakOuter-- fileClose hdl
− Examples/Radio.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Radio(radio) where--import Development.NSIS-import Development.NSIS.Plugins.EnvVarUpdate-import Development.NSIS.Plugins.Sections---radio = do- name "Radio"- outFile "radio.exe"- installDir "$DESKTOP/Radio"- requestExecutionLevel User-- -- page Directory- page Components- page InstFiles-- section "Core files" [Required] $ do- setOutPath "$INSTDIR"- file [] "Examples/Radio.hs"-- local <- section "Add to user %PATH%" [] $ do- setEnvVarPrepend HKCU "PATH" "$INSTDIR"- global <- section "Add to system %PATH%" [] $ do- setEnvVarPrepend HKLM "PATH" "$INSTDIR"- atMostOneSection [local,global]-- a <- section "I like Marmite" [] $ return ()- b <- section "I hate Marmite" [] $ return ()- c <- section "I don't care" [] $ return ()- exactlyOneSection [a,b,c]
− Examples/Taskbar.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Taskbar(taskbar) where--import Control.Monad-import Development.NSIS-import qualified Development.NSIS.Plugins.Taskbar as T---taskbar = do- name "taskbar"- allowRootDirInstall True- outFile "taskbar.exe"- caption "Taskbar test"- showInstDetails Show- installDir "$EXEDIR"- requestExecutionLevel User- addPluginDir "."- T.taskbar-- page Directory- page InstFiles-- section "" [] $- replicateM_ 20 $ do- sleep 100- detailPrint "hello"
− Examples/WinMessages.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.WinMessages(winmessages) where--import Development.NSIS-import Development.NSIS.Plugins.WinMessages---winmessages = do- name "winmessages"- outFile "winmessages.exe"- requestExecutionLevel User-- section "" [] $ do- wnd <- findWindow "#32770" "" (Just hwndParent)- ctl <- getDlgItem wnd 1027- _ <- sendMessage [] ctl wm_SETTEXT (0 :: Exp Int) ("STR:MyText" :: Exp String)- return ()--{--Section- FindWindow $0 '#32770' '' $HWNDPARENT- GetDlgItem $1 $0 1027- SendMessage $1 ${WM_SETTEXT} 0 'STR:MyText'-SectionEnd--}
− Main.hs
@@ -1,67 +0,0 @@--module Main(main) where--import Control.Monad-import Data.List-import Data.Maybe-import System.Process-import System.Directory-import System.Environment-import System.Exit--import Development.NSIS-import Examples.Base64-import Examples.Example1-import Examples.Example2-import Examples.Finish-import Examples.Primes-import Examples.Radio-import Examples.Taskbar-import Examples.WinMessages-import Examples.EnvVarUpdate---examples = let (*) = (,) in- ["example1" * void example1, "example2" * void example2, "base64" * void base64- ,"finish" * void finish, "primes" * void primes, "radio" * void radio, "taskbar" * void taskbar- ,"winmessages" * void winmessages, "envvarupdate" * void envvarupdate]---main = do- args <- getArgs- let (flags,names) = partition ("-" `isPrefixOf`) args- when ("--help" `elem` flags) $ do- putStr $ unlines- ["nsis-test [FLAGS] [EXAMPLES]"- ,"Examples:"- ," " ++ unwords (map fst examples)- ,"Flags:"- ," --help Show this message"- ," --nowrite Don't write out the scripts"- ," --nobuild Don't build"- ," --build Do build"- ," --run Run the result"- ]- exitSuccess- when (null args) $ do- putStrLn "*****************************************************************"- putStrLn "** Running nsis test suite, run with '--help' to see arguments **"- putStrLn "*****************************************************************"- names <- return $ if null names then map fst examples else names-- b <- findExecutable "makensis"- let build | "--build" `elem` flags = True- | "--nobuild" `elem` flags = False- | otherwise = isJust b-- forM_ names $ \name -> do- let script = fromMaybe (error $ "Unknown example: " ++ name) $ lookup name examples- unless ("--nowrite" `elem` flags) $ writeFile (name ++ ".nsi") $ nsis script- when build $ do- r <- system $ "makensis -V3 " ++ name ++ ".nsi"- when (r /= ExitSuccess) $ error "NSIS FAILED"- when ("--run" `elem` flags) $ do- system $ name ++ ".exe"- return ()- when (isNothing b) $- putStrLn "Warning: No nsis on the PATH, files were not built"
README.md view
@@ -1,4 +1,4 @@-# NSIS Manual [](https://hackage.haskell.org/package/nsis) [](https://travis-ci.org/ndmitchell/nsis)+# NSIS Manual [](https://hackage.haskell.org/package/nsis) [](https://travis-ci.org/ndmitchell/nsis) This library makes it easier to write [NSIS Windows Installers](http://nsis.sourceforge.net/). You should use this library if:
nsis.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: nsis-version: 0.3.1+version: 0.3.2 license: BSD3 license-file: LICENSE category: Development@@ -9,7 +9,7 @@ maintainer: Neil Mitchell <ndmitchell@gmail.com> copyright: Neil Mitchell 2012-2017 synopsis: DSL for producing Windows Installer using NSIS.-tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 description: NSIS (Nullsoft Scriptable Install System, <http://nsis.sourceforge.net/>) is a tool that allows programmers to create installers for Windows.@@ -29,11 +29,15 @@ library default-language: Haskell2010+ hs-source-dirs: src build-depends: base == 4.*, transformers >= 0.2, uniplate >= 1.5 + if impl(ghc < 8.0)+ build-depends: semigroups >= 0.18+ exposed-modules: Development.NSIS Development.NSIS.Plugins.Base64@@ -52,8 +56,10 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs+ hs-source-dirs: test build-depends: base == 4.*,+ nsis, transformers >= 0.2, uniplate >= 1.5, directory,
+ src/Development/NSIS.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++-- | NSIS (Nullsoft Scriptable Install System, <http://nsis.sourceforge.net/>) is a tool that allows programmers+-- to create installers for Windows.+-- This library provides an alternative syntax for NSIS scripts, as an embedded Haskell language, removing much+-- of the hard work in developing an install script. Simple NSIS installers should look mostly the same, complex ones should+-- be significantly more maintainable.+--+-- As a simple example of using this library:+--+-- @+--import "Development.NSIS"+--+--main = writeFile \"example1.nsi\" $ 'nsis' $ do+-- 'name' \"Example1\" -- The name of the installer+-- 'outFile' \"example1.exe\" -- Where to produce the installer+-- 'installDir' \"$DESKTOP/Example1\" -- The default installation directory+-- 'requestExecutionLevel' 'User' -- Request application privileges for Windows Vista+-- -- Pages to display+-- 'page' 'Directory' -- Pick where to install+-- 'page' 'InstFiles' -- Give a progress bar while installing+-- -- Groups fo files to install+-- 'section' \"\" [] $ do+-- 'setOutPath' \"$INSTDIR\" -- Where to install files in this section+-- 'file' [] \"Example1.hs\" -- File to put into this section+-- @+--+-- The file @example1.nsi@ can now be processed with @makensis@ to produce the installer @example1.exe@.+-- For more examples, see the @Examples@ source directory.+--+-- Much of the documentation from the Installer section is taken from the NSIS documentation.+module Development.NSIS+ (+ -- * Core types+ nsis, nsisNoOptimise, Action, Exp, Value,+ -- * Scripting+ -- ** Variables+ share, scope, constant, constant_, mutable, mutable_, (@=),+ -- ** Typed variables+ mutableInt, constantInt, mutableInt_, constantInt_, mutableStr, constantStr, mutableStr_, constantStr_,+ -- ** Control Flow+ iff, iff_, while, loop, onError,+ (?), (%&&), (%||),+ Label, newLabel, label, goto,+ -- ** Expressions+ str, int, bool,+ (%==), (%/=), (%<=), (%<), (%>=), (%>),+ true, false, not_,+ strRead, strShow,+ (&), strConcat, strLength, strTake, strDrop, strReplace, strIsPrefixOf, strIsSuffixOf, strUnlines, strCheck,+ -- ** File system manipulation+ FileHandle, fileOpen, fileWrite, fileClose, withFile', writeFile', writeFileLines,+ rmdir, delete, copyFiles,+ getFileTime, fileExists, findEach,+ createDirectory, createShortcut,+ -- ** Registry manipulation+ readRegStr, deleteRegKey, deleteRegValue, writeRegStr, writeRegExpandStr, writeRegDWORD,+ -- ** Environment variables+ envVar,+ -- ** Process execution+ exec, execWait, execShell, sleep, abort,+ -- ** Windows+ HWND, hwndParent, findWindow, getDlgItem, sendMessage,+ -- ** Plugins+ plugin, push, pop, exp_,+ addPluginDir,+ -- * Installer+ -- ** Global installer options+ name, outFile, installDir, setCompressor,+ installIcon, uninstallIcon, headerImage,+ installDirRegKey, allowRootDirInstall, caption,+ showInstDetails, showUninstDetails, unicode,+ requestExecutionLevel,+ -- ** Sections+ SectionId, section, sectionGroup, newSectionId,+ sectionSetText, sectionGetText, sectionSet, sectionGet,+ uninstall, page, unpage, finishOptions,+ -- ** Events+ event, onSelChange,+ onPageShow, onPagePre, onPageLeave,+ -- ** Section commands+ file, alwaysNonFatal, writeUninstaller, alert, setOutPath, messageBox,+ hideProgress, detailPrint, setDetailsPrint,+ -- * Escape hatch+ unsafeInject, unsafeInjectGlobal,+ -- * Settings+ Compressor(..), HKEY(..), MessageBoxType(..), Attrib(..), Page(..), Level(..), Visibility(..),+ FileMode(..), SectionFlag(..), ShowWindow(..), FinishOptions(..), DetailsPrint(..)+ ) where++import Control.Monad+import Development.NSIS.Sugar+import Development.NSIS.Show+import Development.NSIS.Optimise+import Development.NSIS.Library+++-- | Create the contents of an NSIS script from an installer specification.+--+-- Beware, 'unsafeInject' and 'unsafeInjectGlobal' may break 'nsis'. The+-- optimizer relies on invariants that may not hold when arbitrary lines are+-- injected. Consider using 'nsisNoOptimise' if problems arise.+nsis :: Action a -> String+nsis = unlines . showNSIS . optimise . runAction . void+++-- | Like 'nsis', but don't try and optimise the resulting NSIS script.+--+-- Useful to figure out how the underlying installer works, or if you believe+-- the optimisations are introducing bugs. Please do report any such bugs,+-- especially if you aren't using 'unsafeInject' or 'unsafeInjectGlobal'!+nsisNoOptimise :: Action a -> String+nsisNoOptimise = unlines . showNSIS . runAction . void
+ src/Development/NSIS/Library.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Development.NSIS.Library where++import Control.Monad+import Development.NSIS.Sugar+++-- | Replace one string with another string, in a target string. As some examples:+--+-- > strReplace "t" "XX" "test" %== "XXesXX"+-- > strReplace "ell" "" "hello world" %== "ho world"+strReplace :: Exp String -> Exp String -> Exp String -> Exp String+strReplace from to str = do+ from <- constant_ from+ to <- constant_ to+ str <- constant_ str+ scope $ do+ rest <- mutable "REST" str+ res <- mutable "RES" ""+ while (rest %/= "") $ do+ iff (from `strIsPrefixOf` rest)+ (do+ res @= res & to+ rest @= strDrop (strLength from) rest)+ (do+ res @= res & strTake 1 rest+ rest @= strDrop 1 rest)+ res++-- | NSIS (the underlying installer, not this library) uses fixed length string buffers,+-- defaulting to 1024 bytes. Any strings longer than+-- the limit may cause truncation or segfaults. You can get builds supporting longer strings+-- from <http://nsis.sourceforge.net/Special_Builds>.+--+-- Given @strCheck msg val@, if @val@ exceeds the limit it will 'abort' with @msg@, otherwise+-- it will return 'val'.+strCheck :: Exp String -> Exp String -> Exp String+strCheck msg x = share x $ \x -> do+ let special = "@!!_NSIS"+ iff_ (not_ $ special `strIsSuffixOf` (x & special)) $ do+ void $ messageBox [MB_ICONSTOP] $ "ERROR: String limit exceeded,\n" & msg+ abort $ "ERROR: String limit exceeded, " & msg+ x+++-- | Is the first string a prefix of the second.+strIsPrefixOf :: Exp String -> Exp String -> Exp Bool+strIsPrefixOf x y = share x $ \x -> share y $ \y ->+ strTake (strLength x) y %== x++-- | Is the first string a prefix of the second.+strIsSuffixOf :: Exp String -> Exp String -> Exp Bool+strIsSuffixOf x y = share x $ \x -> share y $ \y ->+ strDrop (strLength y - strLength x) y %== x+++-- | Join together a list of strings with @\\r\\n@ after each line. Note that unlike standard 'unlines',+-- we use the Windows convention line separator.+strUnlines :: [Exp String] -> Exp String+strUnlines = strConcat . map (& "\r\n")+++-- | Write a file comprising of a set of lines.+writeFileLines :: Exp FilePath -> [Exp String] -> Action ()+writeFileLines a b = withFile' ModeWrite a $ \hdl ->+ forM_ b $ \s -> fileWrite hdl $ s & "\r\n"+++infixr 3 %&&+infixr 2 %||++-- | Short circuiting boolean operators, equivalent to '&&' and '||' but on 'Exp'.+(%&&), (%||) :: Exp Bool -> Exp Bool -> Exp Bool+(%&&) a b = a ? (b, false)+(%||) a b = a ? (true, b)+++-- | With a 'fileOpen' perform some action, then automatically call 'fileClose'.+-- If the action argument jumps out of the section then the 'fileClose' call will be missed.+withFile' :: FileMode -> Exp FilePath -> (Exp FileHandle -> Action ()) -> Action ()+withFile' mode name act = do+ hdl <- fileOpen mode name+ act hdl+ fileClose hdl++-- | Write a file, like 'writeFile'.+writeFile' :: Exp FilePath -> Exp String -> Action ()+writeFile' name contents = withFile' ModeWrite name $ \hdl -> fileWrite hdl contents
+ src/Development/NSIS/Optimise.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE PatternGuards, LambdaCase #-}++module Development.NSIS.Optimise(optimise) where++import Development.NSIS.Type+import Data.Generics.Uniplate.Data+import Data.List+import Data.Maybe+++-- before: secret = 1021, primes = 109++optimise :: [NSIS] -> [NSIS]+optimise =+ -- allow Label 0+ rep (elimDeadLabel . useLabel0) .+ -- disallow Label 0+ rep (elimDeadLabel . elimAfterGoto . deadAssign . assignSwitch . dullGoto . knownCompare . elimLabeledGoto . elimDeadVar)+++rep :: ([NSIS] -> [NSIS]) -> [NSIS] -> [NSIS]+rep f x = g (measure x) x+ where+ g n1 x1 = if n2 < n1 then g n2 x2 else x2+ where x2 = f $ f $ f $ f x1+ n2 = measure x2+ measure x = length (universeBi x :: [NSIS])+++useLabel0 :: [NSIS] -> [NSIS]+useLabel0 = map (descendBi useLabel0) . f+ where+ f (x:Labeled next:xs)+ | null (children x :: [NSIS]) -- must not be a block with nested instructions+ = descendBi (\i -> if i == next then Label 0 else i) x : Labeled next : f xs+ f (x:xs) = x : f xs+ f [] = []+++-- Label whose next statement is a good, +elimLabeledGoto :: [NSIS] -> [NSIS]+elimLabeledGoto x = transformBi f x+ where+ f (Labeled x) = Labeled x+ f x | null (children x) = descendBi moveBounce x+ | otherwise = x++ moveBounce x = fromMaybe x $ lookup x bounce+ bounce = flip concatMap (universe x) $ \case+ Labeled x:Goto y:_ -> [(x,y)]+ Labeled x:Labeled y:_ -> [(x,y)]+ _ -> []+++-- Delete variables which are only assigned, never read from+elimDeadVar :: [NSIS] -> [NSIS]+elimDeadVar x = transform f x+ where+ f (Assign x _:xs) | x `elem` unused = xs+ f xs = xs++ unused = nub assign \\ nub used+ used = every \\ assign+ every = universeBi x+ assign = [x | Assign x _ <- universeBi x]++jumpy Goto{} = True+jumpy StrCmpS{} = True+jumpy IntCmp{} = True+jumpy IfErrors{} = True+jumpy IfFileExists{} = True+jumpy MessageBox{} = True+jumpy _ = False+++-- Eliminate any code after a goto, until a label+elimAfterGoto :: [NSIS] -> [NSIS]+elimAfterGoto x = transformBi f x+ where+ f (x:xs) | jumpy x = x : g xs+ f x = x++ g (Labeled x:xs) = Labeled x:xs+ g (x:xs) = g xs+ g x = x+++-- Be careful to neither introduce or remove label based errors+elimDeadLabel :: [NSIS] -> [NSIS]+elimDeadLabel x = transform f x+ where+ f (Labeled x:xs) | x `elem` unused = xs+ f xs = xs++ unused = nub label \\ nub gotos+ gotos = every \\ label+ every = universeBi x+ label = [x | Labeled x <- universeBi x]+++dullGoto :: [NSIS] -> [NSIS]+dullGoto = transform f+ where+ f (Goto l1:Labeled l2:xs) | l1 == l2 = Labeled l2 : xs+ f x = x+++-- A tricky one! Comparison after jump+knownCompare :: [NSIS] -> [NSIS]+knownCompare x = transform f x+ where+ f (Assign var val : StrCmpS a b yes no : xs)+ | a == [Var_ var], Just eq <- isEqual b val+ = Assign var val : Goto (if eq then yes else no) : xs++ -- grows, but only a finite amount+ f (Assign var val : Labeled l : StrCmpS a b yes no : xs)+ | a == [Var_ var], Just eq <- isEqual b val+ = Assign var val : Goto (if eq then yes else no) : Labeled l : StrCmpS a b yes no : xs++ f (Assign var val : c : xs) | jumpy c = Assign var val : transformBi g c : xs+ where+ g l | Just (StrCmpS a b yes no) <- lookup l cmps+ , a == [Var_ var], Just eq <- isEqual b val+ = if eq then yes else no+ g l = l+ f x = x++ cmps = [(l,cmp) | Labeled l : cmp@StrCmpS{} : _ <- universeBi x]+++isEqual :: Val -> Val -> Maybe Bool+isEqual x y | x == y = Just True+ | isLit x, isLit y = Just False+ | otherwise = Nothing+ where+ isLit = all isLiteral+ isLiteral Literal{} = True+ isLiteral _ = False+++assignSwitch :: [NSIS] -> [NSIS]+assignSwitch = transform f+ where+ -- this rule just switches the assignment, back and forth, ad infinitum+ -- not very principled!+ f (IntOp out1 a b c : Assign other ([Var_ out2]) : xs)+ | out1 == out2+ = IntOp other a b c : Assign out1 ([Var_ other]) : xs+ f x = x+++deadAssign :: [NSIS] -> [NSIS]+deadAssign = transform f+ where+ f (Assign v x:xs) | isDead v xs = xs+ f xs = xs++ isDead v (Labeled _:xs) = isDead v xs+ isDead v (Assign v2 x:xs) = v `notElem` universeBi x && (v == v2 || isDead v xs)+ isDead v _ = False
+ src/Development/NSIS/Plugins/Base64.hs view
@@ -0,0 +1,19 @@++-- | Base64 plugin: <http://nsis.sourceforge.net/Base64_plug-in>+module Development.NSIS.Plugins.Base64(encrypt, decrypt) where++import Development.NSIS+++-- | Base64 data encryption.+encrypt :: Exp String -> Exp String+encrypt x = share x $ \x -> do+ plugin "Base64" "Encrypt" [exp_ x, exp_ $ strLength x]+ pop+++-- | Base64 decryption. Reverse of 'encrypt'.+decrypt :: Exp String -> Exp String+decrypt x = share x $ \x -> do+ plugin "Base64" "Decrypt" [exp_ x, exp_ $ strLength x]+ pop
+ src/Development/NSIS/Plugins/EnvVarUpdate.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Module for updating environment variables. All functions take either 'HKLM' to modify the+-- variable for the machine, or 'HKCU' to modify for the user.+--+-- /Warning:/ If you are modifying PATH, make sure you use a special build of NSIS which can cope+-- with longer strings, or you will corrupt your users path.+module Development.NSIS.Plugins.EnvVarUpdate(+ getEnvVar, setEnvVar, deleteEnvVar,+ setEnvVarAppend, setEnvVarPrepend, setEnvVarRemove+ ) where++import Development.NSIS+import Development.NSIS.Plugins.WinMessages+import Control.Monad+import Data.String+++resolve :: HKEY -> String+resolve h | h == HKLM || h == HKEY_LOCAL_MACHINE = "SYSTEM/CurrentControlSet/Control/Session Manager/Environment"+ | h == HKCU || h == HKEY_CURRENT_USER = "Environment"+ | otherwise = error $ "Development.NSIS.Plugins.EnvVarUpdate, must use either HKLM or HKCU, got: " ++ show h+++-- | Given a string, and a ; separated variable, remove the string from it if it is present.+remove :: Exp String -> Exp String -> Exp String+remove x xs = share x $ \x -> share xs $ \xs -> do+ xs <- mutable_ xs+ xs @= strReplace (";" & x & ";") ";" xs+ while ((x & ";") `strIsPrefixOf` xs) $ xs @= strDrop (strLength x + 1) xs+ while ((";" & x) `strIsSuffixOf` xs) $ xs @= strTake (strLength xs - 1 - strLength x) xs+ iff_ (x %== xs) $ xs @= ""+ xs+++-- | Set an environment variable by writing to the registry.+setEnvVar :: HKEY -> Exp String -> Exp String -> Action ()+setEnvVar h key val = do+ writeRegExpandStr h (fromString $ resolve h) key (strCheck ("setting environment variable %" & key & "%") val)+ void $ sendMessage [Timeout 5000] hwnd_BROADCAST wm_WININICHANGE (0 :: Exp Int) ("STR:Environment" :: Exp String)+++-- | Read a variable from the registry. If you are not modifying the variable+-- you should use 'envVar' instead.+getEnvVar :: HKEY -> Exp String -> Exp String+getEnvVar h key = strCheck ("reading environment variable %" & key & "%") $ readRegStr h (fromString $ resolve h) key+++-- | Delete the environment variable in the registry.+deleteEnvVar :: HKEY -> Exp String -> Action ()+deleteEnvVar h key = do+ deleteRegValue h (fromString $ resolve h) key+ void $ sendMessage [Timeout 5000] hwnd_BROADCAST wm_WININICHANGE (0 :: Exp Int) ("STR:Environment" :: Exp String)+++setEnvVarAppend :: HKEY -> Exp String -> Exp String -> Action ()+setEnvVarAppend h key val = share val $ \val -> setEnvVar h key $ remove val (getEnvVar h key) & ";" & val++setEnvVarPrepend :: HKEY -> Exp String -> Exp String -> Action ()+setEnvVarPrepend h key val = share val $ \val -> setEnvVar h key $ val & ";" & remove val (getEnvVar h key)++setEnvVarRemove :: HKEY -> Exp String -> Exp String -> Action ()+setEnvVarRemove h key val = setEnvVar h key $ remove val $ getEnvVar h key
+ src/Development/NSIS/Plugins/Sections.hs view
@@ -0,0 +1,47 @@++-- | Plugin to change how many sections can be selected at once.+module Development.NSIS.Plugins.Sections(atMostOneSection, exactlyOneSection) where++import Control.Monad+import Development.NSIS+++atMostOneSection :: [SectionId] -> Action ()+atMostOneSection xs = do+ selected <- mutableInt_ (-1)+ let ensure = do+ -- find the lowest selected, which isn't already equal to selected+ prev <- constant_ selected+ forM_ (reverse $ zip [0..] xs) $ \(i,x) -> do+ iff_ (prev %/= int i %&& sectionGet x SF_Selected) $ do+ selected @= int i++ -- ensure only (at most) selected is actually selected+ forM_ (zip [0..] xs) $ \(i,x) -> do+ iff_ (selected %/= int i %&& sectionGet x SF_Selected) $+ sectionSet x SF_Selected false+ ensure+ onSelChange ensure++exactlyOneSection :: [SectionId] -> Action ()+exactlyOneSection xs = do+ selected <- mutableInt_ (-1)++ let ensure = do+ -- find the lowest selected, which isn't already equal to selected+ prev <- constant_ selected+ forM_ (reverse $ zip [0..] xs) $ \(i,x) ->+ iff_ (prev %/= int i %&& sectionGet x SF_Selected) $+ selected @= int i+ iff_ (selected %== (-1)) $+ selected @= 0++ -- ensure only selected is actually selected+ forM_ (zip [0..] xs) $ \(i,x) -> do+ let b = selected %== int i+ iff_ (b %/= sectionGet x SF_Selected) $+ sectionSet x SF_Selected b++ ensure+ onSelChange ensure+
+ src/Development/NSIS/Plugins/Taskbar.hs view
@@ -0,0 +1,10 @@++-- | Windows 7 Taskbar Progress plugin: <http://nsis.sourceforge.net/TaskbarProgress_plug-in>+module Development.NSIS.Plugins.Taskbar(taskbar) where++import Development.NSIS+++-- | Enable Windows 7 taskbar plugin, called anywhere.+taskbar :: Action ()+taskbar = onPageShow InstFiles $ plugin "w7tbp" "Start" []
+ src/Development/NSIS/Plugins/WinMessages.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-|+List of common Windows Messages++2005 Shengalts Aleksander aka Instructor <Shengalts@mail.ru>++For usage example see @Examples\/WinMessages.hs@.++> Prefix Message category+> -------------------------+> SW ShowWindow Commands+> BM Button control+> CB Combo box control+> EM Edit control+> LB List box control+> WM General window+> ABM Application desktop toolbar+> DBT Device+> DM Default push button control+> HDM Header control+> LVM List view control+> SB Status bar window+> SBM Scroll bar control+> STM Static control+> TCM Tab control+> PBM Progress bar++> NOT included messages (WM_USER + X)+> -----------------------------------+> CBEM Extended combo box control+> CDM Common dialog box+> DL Drag list box+> DTM Date and time picker control+> HKM Hot key control+> IPM IP address control+> MCM Month calendar control+> PGM Pager control+> PSM Property sheet+> RB Rebar control+> TB Toolbar+> TBM Trackbar+> TTM Tooltip control+> TVM Tree-view control+> UDM Up-down control+-}+module Development.NSIS.Plugins.WinMessages where++hwnd_BROADCAST = 0xFFFF++-- ShowWindow Commands+sw_HIDE = 0+sw_SHOWNORMAL = 1+sw_NORMAL = 1+sw_SHOWMINIMIZED = 2+sw_SHOWMAXIMIZED = 3+sw_MAXIMIZE = 3+sw_SHOWNOACTIVATE = 4+sw_SHOW = 5+sw_MINIMIZE = 6+sw_SHOWMINNOACTIVE = 7+sw_SHOWNA = 8+sw_RESTORE = 9+sw_SHOWDEFAULT = 10+sw_FORCEMINIMIZE = 11+sw_MAX = 11++-- Button Control Messages --+bm_CLICK = 0x00F5+bm_GETCHECK = 0x00F0+bm_GETIMAGE = 0x00F6+bm_GETSTATE = 0x00F2+bm_SETCHECK = 0x00F1+bm_SETIMAGE = 0x00F7+bm_SETSTATE = 0x00F3+bm_SETSTYLE = 0x00F4++bst_UNCHECKED = 0+bst_CHECKED = 1+bst_INDETERMINATE = 2+bst_PUSHED = 4+bst_FOCUS = 8++-- Combo Box Messages --+cb_ADDSTRING = 0x0143+cb_DELETESTRING = 0x0144+cb_DIR = 0x0145+cb_FINDSTRING = 0x014C+cb_FINDSTRINGEXACT = 0x0158+cb_GETCOUNT = 0x0146+cb_GETCURSEL = 0x0147+cb_GETDROPPEDCONTROLRECT = 0x0152+cb_GETDROPPEDSTATE = 0x0157+cb_GETDROPPEDWIDTH = 0x015f+cb_GETEDITSEL = 0x0140+cb_GETEXTENDEDUI = 0x0156+cb_GETHORIZONTALEXTENT = 0x015d+cb_GETITEMDATA = 0x0150+cb_GETITEMHEIGHT = 0x0154+cb_GETLBTEXT = 0x0148+cb_GETLBTEXTLEN = 0x0149+cb_GETLOCALE = 0x015A+cb_GETTOPINDEX = 0x015b+cb_INITSTORAGE = 0x0161+cb_INSERTSTRING = 0x014A+cb_LIMITTEXT = 0x0141+cb_MSGMAX = 0x015B -- 0x0162 0x0163+cb_MULTIPLEADDSTRING = 0x0163+cb_RESETCONTENT = 0x014B+cb_SELECTSTRING = 0x014D+cb_SETCURSEL = 0x014E+cb_SETDROPPEDWIDTH = 0x0160+cb_SETEDITSEL = 0x0142+cb_SETEXTENDEDUI = 0x0155+cb_SETHORIZONTALEXTENT = 0x015e+cb_SETITEMDATA = 0x0151+cb_SETITEMHEIGHT = 0x0153+cb_SETLOCALE = 0x0159+cb_SETTOPINDEX = 0x015c+cb_SHOWDROPDOWN = 0x014F++cb_ERR = -1++-- Edit Control Messages --+em_CANUNDO = 0x00C6+em_CHARFROMPOS = 0x00D7+em_EMPTYUNDOBUFFER = 0x00CD+em_EXLIMITTEXT = 0x0435+em_FMTLINES = 0x00C8+em_GETFIRSTVISIBLELINE = 0x00CE+em_GETHANDLE = 0x00BD+em_GETIMESTATUS = 0x00D9+em_GETLIMITTEXT = 0x00D5+em_GETLINE = 0x00C4+em_GETLINECOUNT = 0x00BA+em_GETMARGINS = 0x00D4+em_GETMODIFY = 0x00B8+em_GETPASSWORDCHAR = 0x00D2+em_GETRECT = 0x00B2+em_GETSEL = 0x00B0+em_GETTHUMB = 0x00BE+em_GETWORDBREAKPROC = 0x00D1+em_LIMITTEXT = 0x00C5+em_LINEFROMCHAR = 0x00C9+em_LINEINDEX = 0x00BB+em_LINELENGTH = 0x00C1+em_LINESCROLL = 0x00B6+em_POSFROMCHAR = 0x00D6+em_REPLACESEL = 0x00C2+em_SCROLL = 0x00B5+em_SCROLLCARET = 0x00B7+em_SETHANDLE = 0x00BC+em_SETIMESTATUS = 0x00D8+em_SETLIMITTEXT = 0x00C5 -- Same as EM_LIMITTEXT+em_SETMARGINS = 0x00D3+em_SETMODIFY = 0x00B9+em_SETPASSWORDCHAR = 0x00CC+em_SETREADONLY = 0x00CF+em_SETRECT = 0x00B3+em_SETRECTNP = 0x00B4+em_SETSEL = 0x00B1+em_SETTABSTOPS = 0x00CB+em_SETWORDBREAKPROC = 0x00D0+em_UNDO = 0x00C7++-- Listbox Messages --+lb_ADDFILE = 0x0196+lb_ADDSTRING = 0x0180+lb_DELETESTRING = 0x0182+lb_DIR = 0x018D+lb_FINDSTRING = 0x018F+lb_FINDSTRINGEXACT = 0x01A2+lb_GETANCHORINDEX = 0x019D+lb_GETCARETINDEX = 0x019F+lb_GETCOUNT = 0x018B+lb_GETCURSEL = 0x0188+lb_GETHORIZONTALEXTENT = 0x0193+lb_GETITEMDATA = 0x0199+lb_GETITEMHEIGHT = 0x01A1+lb_GETITEMRECT = 0x0198+lb_GETLOCALE = 0x01A6+lb_GETSEL = 0x0187+lb_GETSELCOUNT = 0x0190+lb_GETSELITEMS = 0x0191+lb_GETTEXT = 0x0189+lb_GETTEXTLEN = 0x018A+lb_GETTOPINDEX = 0x018E+lb_INITSTORAGE = 0x01A8+lb_INSERTSTRING = 0x0181+lb_ITEMFROMPOINT = 0x01A9+lb_MSGMAX = 0x01A8 -- 0x01B0 0x01B1+lb_MULTIPLEADDSTRING = 0x01B1+lb_RESETCONTENT = 0x0184+lb_SELECTSTRING = 0x018C+lb_SELITEMRANGE = 0x019B+lb_SELITEMRANGEEX = 0x0183+lb_SETANCHORINDEX = 0x019C+lb_SETCARETINDEX = 0x019E+lb_SETCOLUMNWIDTH = 0x0195+lb_SETCOUNT = 0x01A7+lb_SETCURSEL = 0x0186+lb_SETHORIZONTALEXTENT = 0x0194+lb_SETITEMDATA = 0x019A+lb_SETITEMHEIGHT = 0x01A0+lb_SETLOCALE = 0x01A5+lb_SETSEL = 0x0185+lb_SETTABSTOPS = 0x0192+lb_SETTOPINDEX = 0x0197++lb_ERR = -1++-- Window Messages --+wm_ACTIVATE = 0x0006+wm_ACTIVATEAPP = 0x001C+wm_AFXFIRST = 0x0360+wm_AFXLAST = 0x037F+wm_APP = 0x8000+wm_APPCOMMAND = 0x0319+wm_ASKCBFORMATNAME = 0x030C+wm_CANCELJOURNAL = 0x004B+wm_CANCELMODE = 0x001F+wm_CAPTURECHANGED = 0x0215+wm_CHANGECBCHAIN = 0x030D+wm_CHANGEUISTATE = 0x0127+wm_CHAR = 0x0102+wm_CHARTOITEM = 0x002F+wm_CHILDACTIVATE = 0x0022+wm_CLEAR = 0x0303+wm_CLOSE = 0x0010+wm_COMMAND = 0x0111+wm_COMMNOTIFY = 0x0044 -- no longer suported+wm_COMPACTING = 0x0041+wm_COMPAREITEM = 0x0039+wm_CONTEXTMENU = 0x007B+wm_CONVERTREQUESTEX = 0x108+wm_COPY = 0x0301+wm_COPYDATA = 0x004A+wm_CREATE = 0x0001+wm_CTLCOLOR = 0x0019+wm_CTLCOLORBTN = 0x0135+wm_CTLCOLORDLG = 0x0136+wm_CTLCOLOREDIT = 0x0133+wm_CTLCOLORLISTBOX = 0x0134+wm_CTLCOLORMSGBOX = 0x0132+wm_CTLCOLORSCROLLBAR = 0x0137+wm_CTLCOLORSTATIC = 0x0138+wm_CUT = 0x0300+wm_DDE_FIRST = 0x3E0+wm_DEADCHAR = 0x0103+wm_DELETEITEM = 0x002D+wm_DESTROY = 0x0002+wm_DESTROYCLIPBOARD = 0x0307+wm_DEVICECHANGE = 0x0219+wm_DEVMODECHANGE = 0x001B+wm_DISPLAYCHANGE = 0x007E+wm_DRAWCLIPBOARD = 0x0308+wm_DRAWITEM = 0x002B+wm_DROPFILES = 0x0233+wm_ENABLE = 0x000A+wm_ENDSESSION = 0x0016+wm_ENTERIDLE = 0x0121+wm_ENTERMENULOOP = 0x0211+wm_ENTERSIZEMOVE = 0x0231+wm_ERASEBKGND = 0x0014+wm_EXITMENULOOP = 0x0212+wm_EXITSIZEMOVE = 0x0232+wm_FONTCHANGE = 0x001D+wm_GETDLGCODE = 0x0087+wm_GETFONT = 0x0031+wm_GETHOTKEY = 0x0033+wm_GETICON = 0x007F+wm_GETMINMAXINFO = 0x0024+wm_GETOBJECT = 0x003D+wm_GETTEXT = 0x000D+wm_GETTEXTLENGTH = 0x000E+wm_HANDHELDFIRST = 0x0358+wm_HANDHELDLAST = 0x035F+wm_HELP = 0x0053+wm_HOTKEY = 0x0312+wm_HSCROLL = 0x0114+wm_HSCROLLCLIPBOARD = 0x030E+wm_ICONERASEBKGND = 0x0027+wm_IME_CHAR = 0x0286+wm_IME_COMPOSITION = 0x010F+wm_IME_COMPOSITIONFULL = 0x0284+wm_IME_CONTROL = 0x0283+wm_IME_ENDCOMPOSITION = 0x010E+wm_IME_KEYDOWN = 0x0290+wm_IME_KEYLAST = 0x010F+wm_IME_KEYUP = 0x0291+wm_IME_NOTIFY = 0x0282+wm_IME_REQUEST = 0x0288+wm_IME_SELECT = 0x0285+wm_IME_SETCONTEXT = 0x0281+wm_IME_STARTCOMPOSITION = 0x010D+wm_INITDIALOG = 0x0110+wm_INITMENU = 0x0116+wm_INITMENUPOPUP = 0x0117+wm_INPUT = 0x00FF+wm_INPUTLANGCHANGE = 0x0051+wm_INPUTLANGCHANGEREQUEST = 0x0050+wm_KEYDOWN = 0x0100+wm_KEYFIRST = 0x0100+wm_KEYLAST = 0x0108+wm_KEYUP = 0x0101+wm_KILLFOCUS = 0x0008+wm_LBUTTONDBLCLK = 0x0203+wm_LBUTTONDOWN = 0x0201+wm_LBUTTONUP = 0x0202+wm_MBUTTONDBLCLK = 0x0209+wm_MBUTTONDOWN = 0x0207+wm_MBUTTONUP = 0x0208+wm_MDIACTIVATE = 0x0222+wm_MDICASCADE = 0x0227+wm_MDICREATE = 0x0220+wm_MDIDESTROY = 0x0221+wm_MDIGETACTIVE = 0x0229+wm_MDIICONARRANGE = 0x0228+wm_MDIMAXIMIZE = 0x0225+wm_MDINEXT = 0x0224+wm_MDIREFRESHMENU = 0x0234+wm_MDIRESTORE = 0x0223+wm_MDISETMENU = 0x0230+wm_MDITILE = 0x0226+wm_MEASUREITEM = 0x002C+wm_MENUCHAR = 0x0120+wm_MENUCOMMAND = 0x0126+wm_MENUDRAG = 0x0123+wm_MENUGETOBJECT = 0x0124+wm_MENURBUTTONUP = 0x0122+wm_MENUSELECT = 0x011F+wm_MOUSEACTIVATE = 0x0021+wm_MOUSEFIRST = 0x0200+wm_MOUSEHOVER = 0x02A1+wm_MOUSELAST = 0x0209 -- 0x020A 0x020D+wm_MOUSELEAVE = 0x02A3+wm_MOUSEMOVE = 0x0200+wm_MOUSEWHEEL = 0x020A+wm_MOVE = 0x0003+wm_MOVING = 0x0216+wm_NCACTIVATE = 0x0086+wm_NCCALCSIZE = 0x0083+wm_NCCREATE = 0x0081+wm_NCDESTROY = 0x0082+wm_NCHITTEST = 0x0084+wm_NCLBUTTONDBLCLK = 0x00A3+wm_NCLBUTTONDOWN = 0x00A1+wm_NCLBUTTONUP = 0x00A2+wm_NCMBUTTONDBLCLK = 0x00A9+wm_NCMBUTTONDOWN = 0x00A7+wm_NCMBUTTONUP = 0x00A8+wm_NCMOUSEHOVER = 0x02A0+wm_NCMOUSELEAVE = 0x02A2+wm_NCMOUSEMOVE = 0x00A0+wm_NCPAINT = 0x0085+wm_NCRBUTTONDBLCLK = 0x00A6+wm_NCRBUTTONDOWN = 0x00A4+wm_NCRBUTTONUP = 0x00A5+wm_NCXBUTTONDBLCLK = 0x00AD+wm_NCXBUTTONDOWN = 0x00AB+wm_NCXBUTTONUP = 0x00AC+wm_NEXTDLGCTL = 0x0028+wm_NEXTMENU = 0x0213+wm_NOTIFY = 0x004E+wm_NOTIFYFORMAT = 0x0055+wm_NULL = 0x0000+wm_PAINT = 0x000F+wm_PAINTCLIPBOARD = 0x0309+wm_PAINTICON = 0x0026+wm_PALETTECHANGED = 0x0311+wm_PALETTEISCHANGING = 0x0310+wm_PARENTNOTIFY = 0x0210+wm_PASTE = 0x0302+wm_PENWINFIRST = 0x0380+wm_PENWINLAST = 0x038F+wm_POWER = 0x0048+wm_POWERBROADCAST = 0x0218+wm_PRINT = 0x0317+wm_PRINTCLIENT = 0x0318+wm_QUERYDRAGICON = 0x0037+wm_QUERYENDSESSION = 0x0011+wm_QUERYNEWPALETTE = 0x030F+wm_QUERYOPEN = 0x0013+wm_QUERYUISTATE = 0x0129+wm_QUEUESYNC = 0x0023+wm_QUIT = 0x0012+wm_RBUTTONDBLCLK = 0x0206+wm_RBUTTONDOWN = 0x0204+wm_RBUTTONUP = 0x0205+wm_RASDIALEVENT = 0xCCCD+wm_RENDERALLFORMATS = 0x0306+wm_RENDERFORMAT = 0x0305+wm_SETCURSOR = 0x0020+wm_SETFOCUS = 0x0007+wm_SETFONT = 0x0030+wm_SETHOTKEY = 0x0032+wm_SETICON = 0x0080+wm_SETREDRAW = 0x000B+wm_SETTEXT = 0x000C+wm_SETTINGCHANGE = 0x001A -- Same as WM_WININICHANGE+wm_SHOWWINDOW = 0x0018+wm_SIZE = 0x0005+wm_SIZECLIPBOARD = 0x030B+wm_SIZING = 0x0214+wm_SPOOLERSTATUS = 0x002A+wm_STYLECHANGED = 0x007D+wm_STYLECHANGING = 0x007C+wm_SYNCPAINT = 0x0088+wm_SYSCHAR = 0x0106+wm_SYSCOLORCHANGE = 0x0015+wm_SYSCOMMAND = 0x0112+wm_SYSDEADCHAR = 0x0107+wm_SYSKEYDOWN = 0x0104+wm_SYSKEYUP = 0x0105+wm_TABLET_FIRST = 0x02C0+wm_TABLET_LAST = 0x02DF+wm_THEMECHANGED = 0x031A+wm_TCARD = 0x0052+wm_TIMECHANGE = 0x001E+wm_TIMER = 0x0113+wm_UNDO = 0x0304+wm_UNICHAR = 0x0109+wm_UNINITMENUPOPUP = 0x0125+wm_UPDATEUISTATE = 0x0128+wm_USER = 0x400+wm_USERCHANGED = 0x0054+wm_VKEYTOITEM = 0x002E+wm_VSCROLL = 0x0115+wm_VSCROLLCLIPBOARD = 0x030A+wm_WINDOWPOSCHANGED = 0x0047+wm_WINDOWPOSCHANGING = 0x0046+wm_WININICHANGE = 0x001A+wm_WTSSESSION_CHANGE = 0x02B1+wm_XBUTTONDBLCLK = 0x020D+wm_XBUTTONDOWN = 0x020B+wm_XBUTTONUP = 0x020C+++-- Application desktop toolbar --+abm_ACTIVATE = 0x00000006 -- lParam == TRUE/FALSE means activate/deactivate+abm_GETAUTOHIDEBAR = 0x00000007+abm_GETSTATE = 0x00000004+abm_GETTASKBARPOS = 0x00000005+abm_NEW = 0x00000000+abm_QUERYPOS = 0x00000002+abm_REMOVE = 0x00000001+abm_SETAUTOHIDEBAR = 0x00000008 -- This can fail, you MUST check the result+abm_SETPOS = 0x00000003+abm_WINDOWPOSCHANGED = 0x0000009++-- Device --+dbt_APPYBEGIN = 0x0000+dbt_APPYEND = 0x0001+dbt_CONFIGCHANGECANCELED = 0x0019+dbt_CONFIGCHANGED = 0x0018+dbt_CONFIGMGAPI32 = 0x0022+dbt_CONFIGMGPRIVATE = 0x7FFF+dbt_CUSTOMEVENT = 0x8006 -- User-defined event+dbt_DEVICEARRIVAL = 0x8000 -- System detected a new device+dbt_DEVICEQUERYREMOVE = 0x8001 -- Wants to remove, may fail+dbt_DEVICEQUERYREMOVEFAILED = 0x8002 -- Removal aborted+dbt_DEVICEREMOVECOMPLETE = 0x8004 -- Device is gone+dbt_DEVICEREMOVEPENDING = 0x8003 -- About to remove, still avail.+dbt_DEVICETYPESPECIFIC = 0x8005 -- Type specific event+dbt_DEVNODES_CHANGED = 0x0007+dbt_DEVTYP_DEVICEINTERFACE = 0x00000005 -- Device interface class+dbt_DEVTYP_DEVNODE = 0x00000001 -- Devnode number+dbt_DEVTYP_HANDLE = 0x00000006 -- File system handle+dbt_DEVTYP_NET = 0x00000004 -- Network resource+dbt_DEVTYP_OEM = 0x00000000 -- Oem-defined device type+dbt_DEVTYP_PORT = 0x00000003 -- Serial, parallel+dbt_DEVTYP_VOLUME = 0x00000002 -- Logical volume+dbt_LOW_DISK_SPACE = 0x0048+dbt_MONITORCHANGE = 0x001B+dbt_NO_DISK_SPACE = 0x0047+dbt_QUERYCHANGECONFIG = 0x0017+dbt_SHELLLOGGEDON = 0x0020+dbt_USERDEFINED = 0xFFFF+dbt_VOLLOCKLOCKFAILED = 0x8043+dbt_VOLLOCKLOCKRELEASED = 0x8045+dbt_VOLLOCKLOCKTAKEN = 0x8042+dbt_VOLLOCKQUERYLOCK = 0x8041+dbt_VOLLOCKQUERYUNLOCK = 0x8044+dbt_VOLLOCKUNLOCKFAILED = 0x8046+dbt_VPOWERDAPI = 0x8100 -- VPOWERD API for Win95+dbt_VXDINITCOMPLETE = 0x0023++-- Default push button control --+dm_BITSPERPEL = 0x00040000+dm_COLLATE = 0x00008000+dm_COLOR = 0x00000800+dm_COPIES = 0x00000100+dm_DEFAULTSOURCE = 0x00000200+dm_DISPLAYFLAGS = 0x00200000+dm_DISPLAYFREQUENCY = 0x00400000+dm_DITHERTYPE = 0x04000000+dm_DUPLEX = 0x00001000+dm_FORMNAME = 0x00010000+dm_GRAYSCALE = 0x00000001 -- This flag is no longer valid+dm_ICMINTENT = 0x01000000+dm_ICMMETHOD = 0x00800000+dm_INTERLACED = 0x00000002 -- This flag is no longer valid+dm_LOGPIXELS = 0x00020000+dm_MEDIATYPE = 0x02000000+dm_NUP = 0x00000040+dm_ORIENTATION = 0x00000001+dm_PANNINGHEIGHT = 0x10000000+dm_PANNINGWIDTH = 0x08000000+dm_PAPERLENGTH = 0x00000004+dm_PAPERSIZE = 0x00000002+dm_PAPERWIDTH = 0x00000008+dm_PELSHEIGHT = 0x00100000+dm_PELSWIDTH = 0x00080000+dm_POSITION = 0x00000020+dm_PRINTQUALITY = 0x00000400+dm_SCALE = 0x00000010+dm_SPECVERSION = 0x0320 -- 0x0400 0x0401+dm_TTOPTION = 0x00004000+dm_YRESOLUTION = 0x00002000++-- Header control --+hdm_FIRST = 0x1200++-- List view control --+lvm_FIRST = 0x1000++-- Status bar window --+sb_CONST_ALPHA = 0x00000001+sb_GRAD_RECT = 0x00000010+sb_GRAD_TRI = 0x00000020+sb_NONE = 0x00000000+sb_PIXEL_ALPHA = 0x00000002+sb_PREMULT_ALPHA = 0x00000004+sb_SIMPLEID = 0x00ff++-- Scroll bar control --+sbm_ENABLE_ARROWS = 0x00E4 -- Not in win3.1+sbm_GETPOS = 0x00E1 -- Not in win3.1+sbm_GETRANGE = 0x00E3 -- Not in win3.1+sbm_GETSCROLLINFO = 0x00EA+sbm_SETPOS = 0x00E0 -- Not in win3.1+sbm_SETRANGE = 0x00E2 -- Not in win3.1+sbm_SETRANGEREDRAW = 0x00E6 -- Not in win3.1+sbm_SETSCROLLINFO = 0x00E9++-- Static control --+stm_GETICON = 0x0171+stm_GETIMAGE = 0x0173+stm_MSGMAX = 0x0174+stm_ONLY_THIS_INTERFACE = 0x00000001+stm_ONLY_THIS_NAME = 0x00000008+stm_ONLY_THIS_PROTOCOL = 0x00000002+stm_ONLY_THIS_TYPE = 0x00000004+stm_SETICON = 0x0170+stm_SETIMAGE = 0x0172++-- Tab control --+tcm_FIRST = 0x1300++-- Progress bar control --+pbm_SETRANGE = 0x0401+pbm_SETPOS = 0x0402+pbm_DELTAPOS = 0x0403+pbm_SETSTEP = 0x0404+pbm_STEPIT = 0x0405+pbm_GETPOS = 0x0408+pbm_SETMARQUEE = 0x040a
+ src/Development/NSIS/Show.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE RecordWildCards #-}++module Development.NSIS.Show(showNSIS) where++import Development.NSIS.Type+import Control.Arrow+import Data.Generics.Uniplate.Data+import Data.Char+import Data.Function+import Data.List+import Data.Maybe+++showNSIS :: [NSIS] -> [String]+showNSIS xs =+ ["!Include MUI2.nsh"] +++ ["Var _" ++ show v | v <- sort $ nub [i | Var i <- universeBi xs]] +++ outs fs (filter isGlobal xs) +++ ["!insertmacro MUI_LANGUAGE \"English\""] +++ (if null plugins then [] else+ ["Function NSIS_UnusedPluginPreload"+ ," # Put all plugins are at the start of the archive, ensuring fast extraction (esp. LZMA solid)"] +++ map indent plugins +++ ["FunctionEnd"]) +++ outs fs (filter isSection xs) +++ concat [("Function " ++ show name) : map indent (outs fs body) ++ ["FunctionEnd"] | (name,body) <- funs] +++ (if null descs then [] else+ ["!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN"] +++ map indent ["!insertmacro MUI_DESCRIPTION_TEXT " ++ show i ++ " " ++ show d | (i,d) <- descs] +++ ["!insertmacro MUI_FUNCTION_DESCRIPTION_END"])+ where descs = filter (not . null . snd) $ concatMap secDescs $ universeBi xs+ inits = filter (\x -> not (isSection x) && not (isGlobal x)) xs+ fs = map fst funs+ funs = map (fst . head &&& concatMap snd) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $+ [(Fun ".onInit",inits) | not $ null inits] ++ [(name,body) | Function name body <- universeBi xs]+ plugins = sort $ nub [a ++ "::" ++ b | Plugin a b _ <- universeBi xs]+++secDescs :: NSIS -> [(SectionId, Val)]+secDescs (Section x _) = [(secId x, secDescription x)]+secDescs (SectionGroup x _) = [(secgId x, secgDescription x)]+secDescs _ = []+++isGlobal :: NSIS -> Bool+isGlobal x = case x of+ Name{} -> True+ OutFile{} -> True+ InstallDir{} -> True+ SetCompressor{} -> True+ InstallIcon{} -> True+ UninstallIcon{} -> True+ HeaderImage{} -> True+ Page{} -> True+ Unpage{} -> True+ RequestExecutionLevel{} -> True+ AddPluginDir{} -> True+ InstallDirRegKey{} -> True+ AllowRootDirInstall{} -> True+ ShowInstDetails{} -> True+ ShowUninstDetails{} -> True+ Caption{} -> True+ Unicode{} -> True+ UnsafeInjectGlobal{} -> True+ _ -> False++isSection :: NSIS -> Bool+isSection x = case x of+ Section{} -> True+ SectionGroup{} -> True+ _ -> False+++outs :: [Fun] -> [NSIS] -> [String]+outs fs = concatMap (out fs)++out :: [Fun] -> NSIS -> [String]+out fs (Assign v x) = ["StrCpy " ++ show v ++ " " ++ show x]+out fs (SetCompressor ACompressor{..}) = [unwords $ "SetCompressor" : ["/solid"|compSolid] ++ ["/final"|compFinal] ++ [map toLower $ show compType]]+out fs (Section ASection{secId=SectionId secId, ..} xs) =+ [unwords $ "Section" : ["/o"|secUnselected] ++ [show $ [Literal "!"|secBold] ++ secName, "_sec" ++ show secId]] +++ map indent (["SectionIn RO" | secRequired] ++ outs fs xs) +++ ["SectionEnd"]+out fs (SectionGroup ASectionGroup{secgId=SectionId secgId, ..} xs) =+ [unwords $ "SectionGroup" : ["/e"|secgExpanded] ++ [show secgName, "_sec" ++ show secgId]] +++ map indent (outs fs xs) +++ ["SectionGroupEnd"]+out fs (File AFile{..}) = [unwords $ "File" : ["/nonfatal"|fileNonFatal] ++ ["/r"|fileRecursive] ++ [show $ Literal "/oname=" : x | Just x <- [fileOName]] ++ [show filePath]]+out fs (Labeled i) = [show i ++ ":"]+out fs (CreateShortcut AShortcut{..}) = return $ unwords $+ ["CreateShortcut", show scFile, show scTarget, show scParameters, show scIconFile+ ,show scIconIndex, show scStartOptions, show scKeyboardShortcut, show scDescription]+out fs (InstallIcon x) = ["!define MUI_ICON " ++ show x]+out fs (UninstallIcon x) = ["!define MUI_UNICON " ++ show x]+out fs (HeaderImage x) = "!define MUI_HEADERIMAGE" : ["!define MUI_HEADERIMAGE_BITMAP " ++ show x | Just x <- [x]]+out fs (Page x) = let y = showPageCtor x in+ ["!define MUI_PAGE_CUSTOMFUNCTION_PRE Pre" ++ y | "Pre" ++ y `elem` map show fs] +++ ["!define MUI_PAGE_CUSTOMFUNCTION_SHOW Show" ++ y | "Show" ++ y `elem` map show fs] +++ ["!define MUI_PAGE_CUSTOMFUNCTION_LEAVE Leave" ++ y | "Leave" ++ y `elem` map show fs] +++ concat [showFinish x | Finish x <- [x]] +++ ["!insertmacro MUI_PAGE_" ++ showPage x]+out fs (Unpage x) = ["!insertmacro MUI_UNPAGE_" ++ showPage x]+out fs Function{} = []+out fs (Delete ADelete{..}) = [unwords $ "Delete" : ["/rebootok"|delRebootOK] ++ [show delFile]]+out fs (RMDir ARMDir{..}) = [unwords $ "RMDir" : ["/r"|rmRecursive] ++ ["/rebootok"|rmRebootOK] ++ [show rmDir]]+out fs (CopyFiles ACopyFiles{..}) = [unwords $ "CopyFiles" : ["/silent"|cpSilent] ++ ["/filesonly"|cpFilesOnly] ++ [show cpFrom, show cpTo]]+out fs (MessageBox flags txt lbls) = [unwords $ "MessageBox" : intercalate "|" (map show flags) : show txt :+ ["ID" ++ a ++ " " ++ show b | (a,b) <- lbls]]+out fs (Goto x) = ["Goto " ++ show x | x /= Label 0]+out fs (IntOp a b "~" _) = [unwords $ "IntOp" : [show a, show b, "~"]] -- the only unary IntOp+out fs (ExecShell AExecShell{..}) = [unwords ["ExecShell","\"\"",show esCommand,show esShow]]+out fs (Plugin a b cs) = [unwords $ (a ++ "::" ++ b) : map show cs]+out fs (AddPluginDir a) = [unwords ["!addplugindir",show a]]+out fs (FindWindow a b c d e) = [unwords $ "FindWindow" : show a : map show ([b,c] ++ maybeToList d ++ maybeToList e)]+out fs (SendMessage a b c d e f) = [unwords $ "SendMessage" : show a : show b : show c : show d : show e : ["/TIMEOUT=" ++ show x | Just x <- [f]]]+out fs (Unicode x) = ["Unicode " ++ if x then "true" else "false"]+out fs (UnsafeInject x) = [x]+out fs (UnsafeInjectGlobal x) = [x]++out fs x = [show x]+++showPage :: Page -> String+showPage (License x) = "LICENSE \"" ++ x ++ "\""+showPage x = map toUpper $ showPageCtor x++showFinish :: FinishOptions -> [String]+showFinish FinishOptions{..} =+ ["!define MUI_FINISHPAGE_RUN " ++ show finRun | finRun /= def] +++ ["!define MUI_FINISHPAGE_RUN_TEXT " ++ show finRunText | finRunText /= def] +++ ["!define MUI_FINISHPAGE_RUN_PARAMETERS " ++ show finRunParamters | finRunParamters /= def] +++ ["!define MUI_FINISHPAGE_RUN_NOTCHECKED" | not finRunChecked && finRun /= def] +++ ["!define MUI_FINISHPAGE_SHOWREADME " ++ show finReadme | finReadme /= def] +++ ["!define MUI_FINISHPAGE_SHOWREADME_TEXT " ++ show finReadmeText | finReadmeText /= def] +++ ["!define MUI_FINISHPAGE_SHOWREADME_NOTCHECKED" | not finReadmeChecked && finReadme /= def] +++ ["!define MUI_FINISHPAGE_LINK_LOCATION " ++ show finLink | finLink /= def] +++ ["!define MUI_FINISHPAGE_LINK " ++ show finLinkText | finLinkText /= def]+++indent x = " " ++ x
+ src/Development/NSIS/Sugar.hs view
@@ -0,0 +1,1170 @@+{-# LANGUAGE OverloadedStrings, EmptyDataDecls, ScopedTypeVariables, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- Bits.popCount only introduced in 7.6+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Applicative and Monoid required < 7.9++module Development.NSIS.Sugar(+ Compressor(..), HKEY(..), MessageBoxType(..), Page(..), Level(..), Visibility(..), FileMode(..), SectionFlag(..),+ ShowWindow(..), FinishOptions(..), DetailsPrint(..),+ module Development.NSIS.Sugar, Label, SectionId+ ) where++import Development.NSIS.Type+import Data.Char+import Data.List+import Data.Maybe+import Data.Semigroup+import qualified Data.List.NonEmpty as NonEmpty+import Data.Monoid hiding ((<>))+import Data.String+import Data.Data+import Data.Bits+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.State+import Data.Generics.Uniplate.Data+++---------------------------------------------------------------------+-- INTERNALS++data S = S+ {uniques :: Int+ ,stream :: [NSIS]+ ,scopes :: [[(String,(TypeRep,Val))]] -- nearest scope is here+ }++-- | Monad in which installers are defined. A useful command to start with is 'section'.+newtype Action a = Action (State S a)+ deriving (Functor, Monad, Applicative)+++-- | A 'Value', only used by 'Exp', which can be produced using 'return'.+-- The @ty@ argument should be one of 'String', 'Int' or 'Bool'.+newtype Value ty = Value {fromValue :: Val}++tyString = typeOf (undefined :: String)+tyInt = typeOf (undefined :: Int)+++unique :: Action Int+unique = Action $ do+ s <- get+ put s{uniques = uniques s + 1}+ return $ uniques s++var :: Action Var+var = fmap Var unique++newSectionId :: Action SectionId+newSectionId = fmap SectionId unique++val x = [Var_ x]+lit x = [Literal x | x /= ""]++-- | Create a new label, used with 'goto' and 'label' to write line jump based programming.+-- Where possible you should use structured alternatives, such as 'iff', 'while' and 'loop'.+-- Each created label must be used with one call to 'label', and any number of calls to+-- 'goto'. As an example:+--+-- @+-- abort <- 'newLabel'+-- 'while' var $ do+-- 'iff_' cond1 $ 'goto' abort+-- 'iff_' cond2 $ 'goto' abort+-- var '@=' 'strDrop' 1 var +-- 'label' abort+-- @+--+-- Note that the above example could have been written in a simpler manner with 'loop'.+newLabel :: Action Label+newLabel = fmap Label unique++emit :: NSIS -> Action ()+emit x = Action $ modify $ \s -> s{stream = stream s ++ [x]}+++rval :: Exp a -> Action Var+rval act = do+ (xs, res) <- capture act+ case res of+ _ | not $ null xs -> error $ "An R-value may not emit any statements: " ++ show xs+ Value [Var_ x] -> return x+ _ -> error $ "An R-value must be a single value, found: " ++ show (fromValue res)+++capture :: Action a -> Action ([NSIS], a)+capture (Action act) = Action $ do+ s0 <- get+ put s0{stream=[]}+ res <- act+ s1 <- get+ put s1{stream=stream s0}+ return (stream s1, res)++runAction :: Action () -> [NSIS]+runAction (Action act) = stream $ execState act s0+ where s0 = S 1 [] [("NSISDIR",(tyString,[Builtin "{NSISDIR}"])):[(x, (tyString, [Builtin x])) | x <- builtin]]+++builtin = words $+ "ADMINTOOLS APPDATA CDBURN_AREA CMDLINE COMMONFILES COMMONFILES32 COMMONFILES64 COOKIES DESKTOP DOCUMENTS " +++ "EXEDIR EXEFILE EXEPATH FAVORITES FONTS HISTORY HWNDPARENT INSTDIR INTERNET_CACHE LANGUAGE LOCALAPPDATA " +++ "MUSIC NETHOOD OUTDIR PICTURES PLUGINSDIR PRINTHOOD PROFILE PROGRAMFILES PROGRAMFILES32 PROGRAMFILES64 " +++ "QUICKLAUNCH RECENT RESOURCES RESOURCES_LOCALIZED SENDTO SMPROGRAMS SMSTARTUP STARTMENU SYSDIR TEMP " +++ "TEMPLATES VIDEOS WINDIR"+++-- | Set all 'file' actions to automatically take 'NonFatal'.+alwaysNonFatal :: Action () -> Action ()+alwaysNonFatal act = do+ (xs, _) <- capture act+ mapM_ emit $ transformBi f xs+ where+ f (File x) = File x{fileNonFatal=True}+ f x = x+++-- | The type of expressions - namely an 'Action' producing a 'Value'. There are instances+-- for 'Num' and 'IsString', and turning on @{-\# LANGUAGE OverloadedStrings \#-}@ is+-- strongly recommended.+--+-- The 'fromString' function converts any embedded @$VAR@ into a variable lookup, which may refer to one of+-- the builtin NSIS variables (e.g. @$SMPROGRAMS@, @$TEMP@, @$PROGRAMFILES@), or a named variable+-- created with 'constant' or 'mutable'. The string @$$@ is used to escape @$@ values.+-- Bracket the variables to put text characters afterwards (e.g. @$(SMPROGRAMS)XXX@). In contrast+-- to standard strings, @\/@ is treated as @\\@ and @\/\/@ is treated as @\/@. Remember to escape any+-- slashes occuring in URLs.+--+-- If the string is @'Exp' 'String'@ then any 'Int' variables used will be automatically shown (see 'strShow').+-- If the string is @'Exp' ty@ then it must be of the form @\"$VAR\"@ where @$VAR@ is a variable of type @ty@.+--+-- The 'Eq' and 'Ord' instances for 'Exp' throw errors for all comparisons (use '%==', '%<=' etc),+-- but 'min' and 'max' are defined. The 'Num' (arithmetic) and 'Monoid' (string concatenation) instances are both+-- fully implemented. From 'Integral' and 'Fractional', only '/', 'mod' and 'div' are implemented, and+-- all as integer arithmetic. No functions from 'Enum' or 'Real' are implemented.+--+-- When using a single expression multiple times, to ensure it is not evaluated+-- repeatedly, use 'share'.+type Exp ty = Action (Value ty)++instance forall a . Typeable a => IsString (Exp a) where+ fromString o = do+ scopes <- Action $ gets scopes+ let rty = typeOf (undefined :: a)++ let grab good name = case lookup name $ concat scopes of+ Nothing -> error $ "Couldn't find variable, $" ++ name ++ ", in " ++ show o+ Just (ty,y)+ | ty `notElem` good -> error $ "Type mismatch, $" ++ name ++ " has " ++ show ty +++ ", but you want one of " ++ show good ++ ", in " ++ show o+ | otherwise -> y++ -- "$VAR" permits any type, everything else requires string+ case parseString o of+ [Right var] -> return $ Value $ grab [rty] var+ + _ | rty /= tyString ->+ error $ "Cannot use concatenated variables/literals to produce anything other than String, but you tried " ++ show rty ++ ", in " ++ show o+ xs -> fmap (Value . fromValue) $ strConcat $ flip map xs $ \i -> return $ Value $ case i of+ Left x -> lit x+ Right name -> grab [tyString,tyInt] name+++parseString :: String -> [Either String String]+parseString "" = []+parseString ('/':'/':xs) = Left "/" : parseString xs+parseString ('/':xs) = Left "\\" : parseString xs+parseString ('$':'$':xs) = Left "$" : parseString xs+parseString ('$':'(':xs) = Right a : parseString (drop 1 b)+ where (a,b) = break (== ')') xs+parseString ('$':xs) = Right a : parseString b+ where (a,b) = span isAlphaNum xs+parseString (x:xs) = Left [x] : parseString xs+++instance Show (Exp a) where+ show _ = error "show is not available for Exp"++instance Eq (Exp a) where+ _ == _ = error "(==) is not available for Exp, try (%==) instead"++instance Num (Exp Int) where+ fromInteger = return . Value . lit . show+ (+) = intOp "+"+ (*) = intOp "*"+ (-) = intOp "-"+ abs a = share a $ \a -> a %< 0 ? (negate a, a)+ signum a = share a $ \a -> a %== 0 ? (0, a %< 0 ? (-1, 1)) ++instance Integral (Exp Int) where+ mod = intOp "%"+ toInteger = error "toInteger is not available for Exp"+ div = intOp "/"+ quotRem = error "quotRem is not available for Exp"++instance Enum (Exp Int) where+ toEnum = error "toEnum is not available for Exp"+ fromEnum = error "toEnum is not available for Exp"++instance Real (Exp Int) where+ toRational = error "toRational is not available for Exp"++instance Ord (Exp Int) where+ compare = error "compare is not available for Exp"+ min a b = share a $ \a -> share b $ \b -> a %<= b ? (a, b)+ max a b = share a $ \a -> share b $ \b -> a %<= b ? (b, a)++instance Fractional (Exp Int) where+ fromRational = error "fromRational is not available for Exp, only Int is supported"+ (/) = intOp "/"++instance Semigroup (Exp String) where+ x <> y = mconcat [x,y]+ sconcat = mconcat . NonEmpty.toList++instance Monoid (Exp String) where+ mempty = fromString ""+ mappend = (<>)+ mconcat xs = do+ xs <- sequence xs+ return $ Value $ f $ concatMap fromValue xs+ where+ f (Literal "":xs) = f xs+ f (Literal x:Literal y:zs) = f $ Literal (x++y) : zs+ f (x:xs) = x : f xs+ f [] = []++instance Bits (Exp Int) where+ (.&.) = intOp "&"+ (.|.) = intOp "|"+ xor = intOp "^"+ complement a = intOp "~" a 0+ shiftL a b = intOp "<<" a (fromInteger $ toInteger b)+ shiftR a b = intOp ">>" a (fromInteger $ toInteger b)+ rotate = error "rotate is not available for Exp"+ bitSize = error "bitSize is not available for Exp"+ isSigned _ = True+ testBit i = error "testBit is not available for Exp"+ bit i = fromInteger $ toInteger (bit i :: Int)++intOp :: String -> Exp Int -> Exp Int -> Exp Int+intOp cmd x y = do Value x <- x; Value y <- y; v <- var; emit $ IntOp v x cmd y; return $ Value $ val v++emit1 :: (Val -> NSIS) -> Exp a -> Action ()+emit1 f x1 = do Value x1 <- x1; emit $ f x1++emit2 :: (Val -> Val -> NSIS) -> Exp a -> Exp b -> Action ()+emit2 f x1 x2 = do Value x1 <- x1; Value x2 <- x2; emit $ f x1 x2++emit3 :: (Val -> Val -> Val -> NSIS) -> Exp a -> Exp b -> Exp c -> Action ()+emit3 f x1 x2 x3 = do Value x1 <- x1; Value x2 <- x2; Value x3 <- x3; emit $ f x1 x2 x3+++infix 1 @=++-- | Assign a value to a mutable variable. The variable must have been originally created with+-- 'mutable' or 'mutable_', or there will be an error when generating the install file.+(@=) :: Exp t -> Exp t -> Action ()+(@=) v w = do v <- rval v; Value w <- w; emit $ Assign v w+++-- | Introduce a variable scope. Scopes are automatically introduced by operations+-- such as 'iff', 'loop', 'while' etc. Inside a scope you may define new variables+-- whose names may clash with variables outside the scope, but the local versions will be used.+--+-- If you have any non-evaluated expressions, before introducing any potentially clashing+-- variables in the scope you should 'share' them or use 'constant_' on them. For example:+--+-- @+-- operate x = do+-- x <- 'constant_' x+-- 'scope' $ do+-- 'constant' \"TEST\" 0+-- @+--+-- It is important to turn @x@ into a 'constant_' before defining a new constant @$TEST@, since+-- if @x@ refers to @$TEST@ after the new definition, it will pick up the wrong variable.+scope :: Action a -> Action a+scope (Action act) = Action $ do+ s0 <- get+ put s0{scopes=[] : scopes s0}+ res <- act+ modify $ \s -> s{scopes = scopes s0}+ return res+++addScope :: forall t . Typeable t => String -> Value t -> Action ()+addScope name v = Action $+ modify $ \s -> let now:rest = scopes s in+ if name `elem` map fst now+ then error $ "Defined twice in one scope, " ++ name+ else s{scopes=((name,(typeOf (undefined :: t), fromValue v)):now):rest}+ +++-- | Create a mutable variable a name, which can be modified with '@='.+-- After defining the expression, you can refer to it with @$NAME@ in a 'String'.+-- To introduce a new scope, see 'scope'.+--+-- @+-- h <- 'mutable' \"HELLO\" \"Hello World\"+-- \"$HELLO\" '@=' \"$HELLO!\"+-- h '@=' \"$HELLO!\" -- equivalent to the above+-- 'alert' \"$HELLO\" -- with 2 exclamation marks+-- @+mutable :: Typeable t => String -> Exp t -> Action (Exp t)+mutable name x = do+ v <- mutable_ x+ vv <- v+ addScope name vv+ return v++-- | Create an unnamed mutable variable, which can be modified with '@='.+--+-- @+-- h <- 'mutable' \"Hello World\"+-- h '@=' 'h' '&' \"!\"+-- 'alert' h+-- @+mutable_ :: Exp t -> Action (Exp t)+mutable_ x = do+ v <- var+ let v2 = return $ Value $ val v+ v2 @= x+ return v2+++-- | Create a constant with a name, ensuring the expression is shared.+-- After defining the expression, you can refer to it with @$NAME@ in a 'String'.+-- To introduce a new scope, see 'scope'.+--+-- @+-- 'constant' \"HELLO\" \"Hello World\"+-- 'alert' \"$HELLO!\"+-- @+constant :: Typeable t => String -> Exp t -> Action (Exp t)+constant name x = do x <- constant_ x; xx <- x; addScope name xx; return x++-- | Create a constant with no name, ensuring the expression is shared.+-- Equivalent to @'share' 'return'@.+constant_ :: Exp t -> Action (Exp t)+constant_ x = do+ -- either the expression is entirely constant, or has mutable variables inside it+ Value x <- x+ if null [() | Var_{} <- x] then+ -- if it's totally constant, we want to leave it that way so it works in non-eval settings (e.g. file)+ return $ return $ Value x+ else do+ -- if it's mutable, we want to share the value, but also snapshot it so that the mutable variables+ -- don't change afterwards+ v <- var+ return (Value $ val v) @= return (Value x)+ -- add the Literal so that assignment throws an error in future+ return $ return $ Value [Var_ v, Literal ""]+++-- | The 'Exp' language is call-by-name, meaning you must use share to avoid evaluating an exression+-- multiple times. Using 'share', if the expression has any side effects+-- they will be run immediately, but not on subsequent uses. When defining functions operating on+-- 'Exp', if you use the same input expression twice, you should share it. For example:+--+-- @+-- strPalindrom x = 'share' x $ \\x -> x '%==' strReverse x+-- @+--+-- If the expression was not shared, and @x@ read from a file, then the file would be read twice.+share :: Exp t -> (Exp t -> Action a) -> Action a+share v act = do v <- constant_ v; act v+++-- | Versions of 'mutable' and 'constant' restricted to 'Exp' 'Int', used to avoid+-- ambiguous type errors.+mutableInt, constantInt :: String -> Exp Int -> Action (Exp Int)+mutableInt = mutable+constantInt = constant++-- | Versions of 'mutable_' and 'constant_' restricted to 'Exp' 'Int', used to avoid+-- ambiguous type errors.+mutableInt_, constantInt_ :: Exp Int -> Action (Exp Int)+mutableInt_ = mutable_+constantInt_ = constant_++-- | Versions of 'mutable' and 'constant' restricted to 'Exp' 'String', used to avoid+-- ambiguous type errors.+mutableStr, constantStr :: String -> Exp String -> Action (Exp String)+mutableStr = mutable+constantStr = constant++-- | Versions of 'mutable_' and 'constant_' restricted to 'Exp' 'String', used to avoid+-- ambiguous type errors.+mutableStr_, constantStr_ :: Exp String -> Action (Exp String)+mutableStr_ = mutable_+constantStr_ = constant_+++---------------------------------------------------------------------+-- EXPRESSION WRAPPERS++-- | Perform string concatenation on a list of expressions.+strConcat :: [Exp String] -> Exp String+strConcat = mconcat++-- | Boolean negation.+not_ :: Exp Bool -> Exp Bool+not_ a = a ? (false, true)++infix 4 %==, %/=, %<=, %<, %>=, %>++-- | The standard equality operators, lifted to 'Exp'.+(%==), (%/=) :: Exp a -> Exp a -> Exp Bool+(%==) a b = do+ Value a <- a+ Value b <- b+ v <- mutable_ false+ eq <- newLabel+ end <- newLabel+ emit $ StrCmpS a b eq end+ label eq+ v @= true+ label end+ v++(%/=) a b = not_ (a %== b)++-- | The standard comparison operators, lifted to 'Exp'.+(%<=), (%<), (%>=), (%>) :: Exp Int -> Exp Int -> Exp Bool+(%<=) = comp True True False+(%<) = comp False True False+(%>=) = comp True False True+(%>) = comp False False True+++comp :: Bool -> Bool -> Bool -> Exp Int -> Exp Int -> Exp Bool+comp eq lt gt a b = do+ Value a <- a+ Value b <- b+ v <- mutable_ false+ yes <- newLabel+ end <- newLabel+ let f b = if b then yes else end+ emit $ IntCmp a b (f eq) (f lt) (f gt)+ label yes+ v @= true+ label end+ v+++-- | Boolean constants corresponding to 'True' and 'False'+true, false :: Exp Bool+false = return $ Value []+true = return $ Value [Literal "1"]++-- | Lift a 'Bool' into an 'Exp'+bool :: Bool -> Exp Bool+bool x = if x then true else false++-- | Lift a 'String' into an 'Exp'+str :: String -> Exp String+str = return . Value . lit++-- | Lift an 'Int' into an 'Exp'+int :: Int -> Exp Int+int = return . Value . lit . show++-- | Erase the type of an Exp, only useful with 'plugin'.+exp_ :: Exp a -> Exp ()+exp_ = fmap (Value . fromValue)++-- | Pop a value off the stack, will set an error if there is nothing on the stack.+-- Only useful with 'plugin'.+pop :: Exp String+pop = do v <- var; emit $ Pop v; return $ Value $ val v++-- | Push a value onto the stack. Only useful with 'plugin'.+push :: Exp a -> Action ()+push a = do Value a <- a; emit $ Push a++-- | Call a plugin. If the arguments are of different types use 'exp_'. As an example:+--+-- @+-- encrypt x = 'share' x $ \\x -> do+-- 'plugin' \"Base64\" \"Encrypt\" ['exp_' x, 'exp_' $ 'strLength' x]+-- @+--+-- The only thing to be careful about is that we use the @x@ parameter twice, so should 'share'+-- it to ensure it is only evaluated once.+plugin :: String -> String -> [Exp a] -> Action ()+plugin dll name args = do args <- mapM (fmap fromValue) args; emit $ Plugin dll name args++-- | Add a plugin directory+addPluginDir :: Exp String -> Action ()+addPluginDir a = do Value a <- a; emit $ AddPluginDir a+++-- | Return the length of a string, @strLength \"test\" '%==' 4@.+strLength :: Exp String -> Exp Int+strLength a = do Value a <- a; v <- var; emit $ StrLen v a; return $ Value $ val v++-- | Take the first @n@ characters from a string, @strTake 2 \"test\" '%==' \"te\"@.+strTake :: Exp Int -> Exp String -> Exp String+strTake n x = do Value n <- n; Value x <- x; v <- var; emit $ StrCpy v x n (lit ""); return $ Value $ val v++-- | Drop the first @n@ characters from a string, @strDrop 2 \"test\" '%==' \"st\"@.+strDrop :: Exp Int -> Exp String -> Exp String+strDrop n x = do Value n <- n; Value x <- x; v <- var; emit $ StrCpy v x (lit "") n; return $ Value $ val v++-- | Gets the last write time of the file, you should only use the result to compare for equality+-- with other results from 'getFileTime'. On failure the error flag is set.+getFileTime :: Exp FilePath -> Exp String+getFileTime x = do Value x <- x; v1 <- var; v2 <- var; emit $ GetFileTime x v1 v2; strConcat [return $ Value $ val v1, "#", return $ Value $ val v2]++readRegStr :: HKEY -> Exp String -> Exp String -> Exp String+readRegStr k a b = do v <- var; emit2 (ReadRegStr v k) a b; return $ Value $ val v++deleteRegKey :: HKEY -> Exp String -> Action ()+deleteRegKey k = emit1 $ DeleteRegKey k++deleteRegValue :: HKEY -> Exp String -> Exp String -> Action ()+deleteRegValue k = emit2 $ DeleteRegValue k++envVar :: Exp String -> Exp String+envVar a = do v <- var; emit1 (ReadEnvStr v) a; return $ Value $ val v+++---------------------------------------------------------------------+-- ATTRIBUTES++data Attrib+ = Solid+ | Final+ | RebootOK+ | Silent+ | FilesOnly+ | NonFatal+ | Recursive+ | Unselected+ | Expanded+ | Description (Exp String)+ | Required+ | Target (Exp String)+ | Parameters (Exp String)+ | IconFile (Exp String)+ | IconIndex (Exp Int)+ | StartOptions String+ | KeyboardShortcut String+ | Id SectionId+ | Timeout Int+ | OName (Exp String)+ deriving Show+++---------------------------------------------------------------------+-- STATEMENT WRAPPERS++-- | Define the location of a 'label', see 'newLabel' for details. This function will fail+-- if the same 'Label' is passed to 'label' more than once.+label :: Label -> Action ()+label lbl = emit $ Labeled lbl++-- | Jump to a 'label', see 'newLabel' for details. This function will fail+-- if 'label' is not used on the 'Label'.+goto :: Label -> Action ()+goto lbl = emit $ Goto lbl+++infix 2 ?++-- | An expression orientated version of 'iff', returns the first component if+-- the first argument is 'true' or the second if it is 'false'.+--+-- @+-- x '%==' 12 '?' (x, x '+' 5)+-- @+(?) :: Exp Bool -> (Exp t, Exp t) -> Exp t+(?) test (true, false) = do+ v <- var+ let v2 = return $ Value $ val v+ iff test (v2 @= true) (v2 @= false)+ v2++-- | Test a boolean expression, reunning the first action if it is 'true' and the second if it is 'false'.+-- The appropriate branch action will be run within a 'scope'. See '?' for an expression orientated version.+--+-- @+-- 'iff' (x '%==' 12) ('alert' \"is 12\") ('alert' \"is not 12\")+-- @+iff :: Exp Bool -> Action () -> Action () -> Action ()+iff test true false = do+ thn <- newLabel+ els <- newLabel+ end <- newLabel+ Value t <- test+ emit $ StrCmpS t (lit "") thn els+ label thn+ scope false+ goto end+ label els+ scope true+ label end+++-- | A version of 'iff' where there is no else action.+iff_ :: Exp Bool -> Action () -> Action ()+iff_ test true = iff test true (return ())+++-- | A while loop, run the second argument while the first argument is true.+-- The action is run in a 'scope'. See also 'loop'.+--+-- @+-- x <- 'mutable_' x+-- 'while' (x '%<' 10) $ do+-- x '@=' x '+' 1+-- @+while :: Exp Bool -> Action () -> Action ()+while test act = do+ start <- newLabel+ label start+ iff_ test (scope act >> goto start)++-- | A loop with a @break@ command. Run the action repeatedly until the breaking action+-- is called. The action is run in a 'scope'. See also 'while'.+--+-- @+-- x <- 'mutable_' x+-- 'loop' $ \\break -> do+-- 'iff_' (x '%>=' 10) break+-- x '@=' x '+' 1+-- @+loop :: (Action () -> Action ()) -> Action ()+loop body = do+ end <- newLabel+ beg <- newLabel+ label beg+ scope $ body $ goto end+ goto beg+ label end++-- | Run an intitial action, and if that action causes an error, run the second action.+-- Unlike other programming languages, any uncaught errors are silently ignored.+-- All actions are run in 'scope'.+--+-- @+-- 'onError' ('exec' \"\\\"$WINDIR/notepad.exe\\\"\") ('alert' \"Failed to run notepad\")+-- @+onError :: Action () -> Action () -> Action ()+onError act catch = do+ emit ClearErrors+ scope act+ end <- newLabel+ err <- newLabel+ emit $ IfErrors err end+ label err+ scope catch+ label end+++-- | Checks for existence of file(s) (which can be a wildcard, or a directory).+-- If you want to check to see if a file is a directory, use @fileExists "DIRECTORY/*.*"@.+--+-- > iff_ (fileExists "$WINDIR/notepad.exe") $+-- > messageBox [MB_OK] "notepad is installed"+fileExists :: Exp FilePath -> Exp Bool+fileExists x = do+ v <- mutable_ false+ Value x <- x+ yes <- newLabel+ end <- newLabel+ emit $ IfFileExists x yes end+ label yes+ v @= true+ label end+ v+++-- | Performs a search for filespec, running the action with each file found.+-- If no files are found the error flag is set. Note that the filename output is without path.+--+-- > findEach "$INSTDIR/*.txt" $ \x ->+-- > detailPrint x+--+-- If you jump from inside the loop to after the loop then you may leak a search handle.+findEach :: Exp FilePath -> (Exp FilePath -> Action ()) -> Action ()+findEach spec act = do+ Value spec <- spec+ hdl <- var+ v <- var+ emit $ FindFirst hdl v spec+ while (return (Value $ val v)) $ do+ scope $ act $ return $ Value $ val v+ emit $ FindNext (val hdl) v+ emit $ FindClose $ val hdl+++infixr 5 &++-- | Concatenate two strings, for example @\"$FOO\" & \"$BAR\"@ is equivalent+-- to @\"$FOO$BAR\"@.+(&) :: Exp String -> Exp String -> Exp String+(&) a b = strConcat [a,b]+++-- | Convert an 'Int' to a 'String' by showing it.+strShow :: Exp Int -> Exp String+strShow = fmap (Value . fromValue)+++-- | Convert a 'String' to an 'Int', any errors are silently ignored.+strRead :: Exp String -> Exp Int+strRead = fmap (Value . fromValue)+++-- | Show an alert, equivalent to @messageBox [MB_ICONEXCLAMATION]@.+alert :: Exp String -> Action ()+alert x = do+ _ <- messageBox [MB_ICONEXCLAMATION] x+ return ()+++++---------------------------------------------------------------------+-- SETTINGS WRAPPERS++-- | Sets the name of the installer. The name is usually simply the product name such as \'MyApp\' or \'Company MyApp\'.+--+-- > name "MyApp"+name :: Exp String -> Action ()+name = emit1 Name++-- | Specifies the output file that @MakeNSIS@ should write the installer to.+-- This is just the file that MakeNSIS writes, it doesn't affect the contents of the installer.+-- Usually should end with @.exe@.+--+-- > outFile "installer.exe"+outFile :: Exp FilePath -> Action ()+outFile = emit1 OutFile++-- | Sets the output path (@$OUTDIR@) and creates it (recursively if necessary), if it does not exist.+-- Must be a full pathname, usually is just @$INSTDIR@.+--+-- > setOutPath "$INSTDIR"+setOutPath :: Exp FilePath -> Action ()+setOutPath = emit1 SetOutPath++-- | Sets the default installation directory.+-- Note that the part of this string following the last @\\@ will be used if the user selects 'browse', and+-- may be appended back on to the string at install time (to disable this, end the directory with a @\\@).+-- If this doesn't make any sense, play around with the browse button a bit.+--+-- > installDir "$PROGRAMFILES/MyApp"+installDir :: Exp FilePath -> Action ()+installDir = emit1 InstallDir++-- | Writes the uninstaller to the filename (and optionally path) specified.+-- Only valid from within an install section, and requires that you have an 'uninstall' section in your script.+-- You can call this one or more times to write out one or more copies of the uninstaller.+--+-- > writeUninstaller "$INSTDIR/uninstaller.exe"+writeUninstaller :: Exp FilePath -> Action ()+writeUninstaller = emit1 WriteUninstaller++-- | Set the icon used for the installer\/uninstaller.+--+-- > installIcon "$NSISDIR/Contrib/Graphics/Icons/modern-install.ico"+installIcon, uninstallIcon :: Exp FilePath -> Action ()+installIcon = emit1 InstallIcon+uninstallIcon = emit1 UninstallIcon++-- | Set the image used for the header splash. Pass 'Nothing' to use the default header image.+--+-- > headerImage $ Just "$NSISDIR/Contrib/Graphics/Header/win.bmp"+headerImage :: Maybe (Exp FilePath) -> Action ()+headerImage Nothing = emit $ HeaderImage Nothing+headerImage (Just x) = emit1 (HeaderImage . Just) x++-- | Creates (recursively if necessary) the specified directory. Errors can be caught+-- using 'onError'. You should always specify an absolute path.+--+-- > createDirectory "$INSTDIR/some/directory"+createDirectory :: Exp FilePath -> Action ()+createDirectory = emit1 CreateDirectory++-- | This attribute tells the installer to check a string in the registry,+-- and use it for the install dir if that string is valid. If this attribute is present,+-- it will override the 'installDir' attribute if the registry key is valid, otherwise+-- it will fall back to the 'installDir' default. When querying the registry, this command+-- will automatically remove any quotes. If the string ends in \".exe\", it will automatically+-- remove the filename component of the string (i.e. if the string is \"C:/program files/foo/foo.exe\",+-- it will know to use \"C:/program files/foo\").+--+-- > installDirRegKey HKLM "Software/NSIS" ""+-- > installDirRegKey HKLM "Software/ACME/Thingy" "InstallLocation"+installDirRegKey :: HKEY -> Exp String -> Exp String -> Action ()+installDirRegKey k = emit2 $ InstallDirRegKey k++-- | Execute the specified program and continue immediately. Note that the file specified+-- must exist on the target system, not the compiling system. @$OUTDIR@ is used for the working+-- directory. Errors can be caught using 'onError'. Note, if the command could have spaces,+-- you should put it in quotes to delimit it from parameters. e.g.: @exec \"\\\"$INSTDIR/command.exe\\\" parameters\"@.+-- If you don't put it in quotes it will not work on Windows 9x with or without parameters.+--+-- > exec "\"$INSTDIR/someprogram.exe\""+-- > exec "\"$INSTDIR/someprogram.exe\" some parameters"+exec :: Exp String -> Action ()+exec = emit1 Exec++execWait :: Exp String -> Action ()+execWait = emit1 ExecWait++execShell :: [ShowWindow] -> Exp String -> Action ()+execShell sw x = do+ Value x <- x+ let d = def{esCommand=x}+ emit $ ExecShell $ if null sw then d else d{esShow=last sw}++sectionSetText :: SectionId -> Exp String -> Action ()+sectionSetText x = emit1 $ SectionSetText x++sectionGetText :: SectionId -> Exp String+sectionGetText x = do v <- var; emit $ SectionGetText x v; return $ Value $ val v++data SectionFlag+ = SF_Selected+ | SF_SectionGroup+ | SF_SectionGroupEnd+ | SF_Bold+ | SF_ReadOnly+ | SF_Expand+ | SF_PartiallySelected+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)++sectionGet :: SectionId -> SectionFlag -> Exp Bool+sectionGet sec flag = do+ v <- var+ emit $ SectionGetFlags sec v+ let b = bit $ fromEnum flag :: Exp Int+ b %== (return (Value $ val v) .&. b)++sectionSet :: SectionId -> SectionFlag -> Exp Bool -> Action ()+sectionSet sec flag set = do+ v <- var+ emit $ SectionGetFlags sec v+ v <- return (return $ Value $ val v :: Exp Int)+ iff set+ (emit1 (SectionSetFlags sec) $ setBit v (fromEnum flag))+ (emit1 (SectionSetFlags sec) $ clearBit v (fromEnum flag))+++-- don't want to accidentally dupe the message box, so make it in Action Exp+messageBox :: [MessageBoxType] -> Exp String -> Action (Exp String)+messageBox ty x = do+ let a*b = (a, words b)+ let alts = [MB_OK * "OK"+ ,MB_OKCANCEL * "OK CANCEL"+ ,MB_ABORTRETRYIGNORE * "ABORT RETRY IGNORE"+ ,MB_RETRYCANCEL * "RETRY CANCEL"+ ,MB_YESNO * "YES NO"+ ,MB_YESNOCANCEL * "YES NO CANCEL"]+ let (btns,rest) = partition (`elem` map fst alts) ty+ let btn = last $ MB_OK : btns+ let alt = fromJust $ lookup btn alts++ end <- newLabel+ lbls <- replicateM (length alt) newLabel+ v <- mutable_ ""+ Value x <- x+ emit $ MessageBox (btn:rest) x $ zip alt lbls+ forM_ (zip alt lbls) $ \(a,l) -> do+ label l+ v @= fromString a+ goto end+ label end+ return v++writeRegStr :: HKEY -> Exp String -> Exp String -> Exp String -> Action ()+writeRegStr k = emit3 $ WriteRegStr k++writeRegExpandStr :: HKEY -> Exp String -> Exp String -> Exp String -> Action ()+writeRegExpandStr k = emit3 $ WriteRegExpandStr k++writeRegDWORD :: HKEY -> Exp String -> Exp String -> Exp Int -> Action ()+writeRegDWORD k = emit3 $ WriteRegDWORD k++-- | While the action is executing, do not update the progress bar.+-- Useful for functions which do a large amount of computation, or have loops.+hideProgress :: Action a -> Action a+hideProgress act = do+ fun <- fmap newFun unique+ (xs, v) <- capture act+ emit $ Function fun xs+ emit $ Call fun+ return v++-- | Sleep time in milliseconds+sleep :: Exp Int -> Action ()+sleep = emit1 Sleep++-- | Create a function, useful for registering actions+event :: String -> Action () -> Action ()+event name act = do+ (xs, _) <- capture act+ emit $ Function (Fun name) xs++onSelChange :: Action () -> Action ()+onSelChange = event ".onSelChange"++onPageShow, onPagePre, onPageLeave :: Page -> Action () -> Action ()+-- these names are special and bound by Show+onPageShow p = event $ "Show" ++ showPageCtor p+onPagePre p = event $ "Pre" ++ showPageCtor p+onPageLeave p = event $ "Show" ++ showPageCtor p++allowRootDirInstall :: Bool -> Action ()+allowRootDirInstall = emit . AllowRootDirInstall++caption :: Exp String -> Action ()+caption = emit1 Caption++detailPrint :: Exp String -> Action ()+detailPrint = emit1 DetailPrint++setDetailsPrint :: DetailsPrint -> Action ()+setDetailsPrint = emit . SetDetailsPrint++showInstDetails :: Visibility -> Action ()+showInstDetails = emit . ShowInstDetails++showUninstDetails :: Visibility -> Action ()+showUninstDetails = emit . ShowUninstDetails++-- | Note: Requires NSIS 3.0+unicode :: Bool -> Action ()+unicode = emit . Unicode++-- | The type of a file handle, created by 'fileOpen'.+data FileHandle deriving Typeable++-- | Open a file, which must be closed explicitly with 'fileClose'.+-- Often it is better to use 'Development.NSIS.Sugar.writeFile'' or+-- 'Development.NSIS.Sugar.withFile' instead.+--+-- @+-- h <- 'fileOpen' 'ModeWrite' \"C:/log.txt\"+-- 'fileWrite' h \"Hello world!\"+-- 'fileClose' h+-- @+fileOpen :: FileMode -> Exp FilePath -> Action (Exp FileHandle)+fileOpen mode name = do+ Value name <- name+ v <- var+ emit $ FileOpen v name mode+ return $ return $ Value $ val v++-- | Write a string to a file openned with 'fileOpen'.+fileWrite :: Exp FileHandle -> Exp String -> Action ()+fileWrite = emit2 FileWrite++-- | Close a file file openned with 'fileOpen'.+fileClose :: Exp FileHandle -> Action ()+fileClose = emit1 FileClose++setCompressor :: Compressor -> [Attrib] -> Action ()+setCompressor x as = emit $ SetCompressor $ foldl f def{compType=x} as+ where+ f c Final = c{compFinal=True}+ f c Solid = c{compSolid=True}+ f c x = error $ "Invalid attribute to setCompress: " ++ show x++file :: [Attrib] -> Exp FilePath -> Action ()+file as x = do Value x <- x; emit . File =<< foldM f def{filePath=x} as+ where+ f c Recursive = return c{fileRecursive=True}+ f c NonFatal = return c{fileNonFatal=True}+ f c (OName x) = do Value x <- x; return c{fileOName=Just x}+ f c x = error $ "Invalid attribute to file: " ++ show x++section :: Exp String -> [Attrib] -> Action () -> Action SectionId+section name as act = do+ sec <- newSectionId+ Value name <- name+ (xs, _) <- capture $ scope act+ x <- foldM f def{secId=sec, secName=name} as+ emit $ Section x xs+ return $ secId x+ where+ f c Unselected = return c{secUnselected=True}+ f c Required = return c{secRequired=True}+ f c (Description x) = do Value x <- x; return c{secDescription=x}+ f c (Id x) = return c{secId=x}+ f c x = error $ "Invalid attribute to section: " ++ show x++sectionGroup :: Exp String -> [Attrib] -> Action () -> Action SectionId+sectionGroup name as act = do+ sec <- newSectionId+ Value name <- name+ (xs, _) <- capture $ scope act+ x <- foldM f def{secgId=sec, secgName=name} as+ emit $ SectionGroup x xs+ return $ secgId x+ where+ f c Expanded = return c{secgExpanded=True}+ f c (Description x) = do Value x <- x; return c{secgDescription=x}+ f c (Id x) = return c{secgId=x}+ f c x = error $ "Invalid attribute to sectionGroup: " ++ show x++uninstall :: Action () -> Action ()+uninstall = void . section "Uninstall" []++-- | Delete file (which can be a file or wildcard, but should be specified with a full path) from the target system.+-- If 'RebootOK' is specified and the file cannot be deleted then the file is deleted when the system reboots --+-- if the file will be deleted on a reboot, the reboot flag will be set. The error flag is set if files are found+-- and cannot be deleted. The error flag is not set from trying to delete a file that does not exist.+--+-- > delete [] "$INSTDIR/somefile.dat"+delete :: [Attrib] -> Exp FilePath -> Action ()+delete as x = do+ Value x <- x+ emit $ Delete $ foldl f def{delFile=x} as+ where+ f c RebootOK = c{delRebootOK=True}+ f c x = error $ "Invalid attribute to delete: " ++ show x++-- | Remove the specified directory (fully qualified path with no wildcards). Without 'Recursive',+-- the directory will only be removed if it is completely empty. If 'Recursive' is specified, the+-- directory will be removed recursively, so all directories and files in the specified directory+-- will be removed. If 'RebootOK' is specified, any file or directory which could not have been+-- removed during the process will be removed on reboot -- if any file or directory will be+-- removed on a reboot, the reboot flag will be set.+-- The error flag is set if any file or directory cannot be removed.+--+-- > rmdir [] "$INSTDIR"+-- > rmdir [] "$INSTDIR/data"+-- > rmdir [Recursive, RebootOK] "$INSTDIR"+-- > rmdir [RebootOK] "$INSTDIR/DLLs"+--+-- Note that the current working directory can not be deleted. The current working directory is+-- set by 'setOutPath'. For example, the following example will not delete the directory.+--+-- > setOutPath "$TEMP/dir"+-- > rmdir [] "$TEMP/dir"+--+-- The next example will succeed in deleting the directory.+--+-- > setOutPath "$TEMP/dir"+-- > setOutPath "$TEMP"+-- > rmdir [] "$TEMP/dir"+--+-- Warning: using @rmdir [Recursive] "$INSTDIR"@ in 'uninstall' is not safe. Though it is unlikely,+-- the user might select to install to the Program Files folder and so this command will wipe out+-- the entire Program Files folder, including other programs that has nothing to do with the uninstaller.+-- The user can also put other files but the program's files and would expect them to get deleted with+-- the program. Solutions are available for easily uninstalling only files which were installed by the installer.+rmdir :: [Attrib] -> Exp FilePath -> Action ()+rmdir as x = do+ Value x <- x+ emit $ RMDir $ foldl f def{rmDir=x} as+ where+ f c RebootOK = c{rmRebootOK=True}+ f c Recursive = c{rmRecursive=True}+ f c x = error $ "Invalid attribute to rmdir: " ++ show x++-- | Both file paths are on the installing system. Do not use relative paths.+copyFiles :: [Attrib] -> Exp FilePath -> Exp FilePath -> Action ()+copyFiles as from to = do+ Value from <- from+ Value to <- to+ emit $ CopyFiles $ foldl f def{cpFrom=from, cpTo=to} as+ where+ f c Silent = c{cpSilent=True}+ f c FilesOnly = c{cpFilesOnly=True}+ f c x = error $ "Invalid attribute to copyFiles: " ++ show x++-- | Creates a shortcut file that links to a 'Traget' file, with optional 'Parameters'. The icon used for the shortcut+-- is 'IconFile','IconIndex'. 'StartOptions' should be one of: SW_SHOWNORMAL, SW_SHOWMAXIMIZED, SW_SHOWMINIMIZED.+-- 'KeyboardShortcut' should be in the form of 'flag|c' where flag can be a combination (using |) of: ALT, CONTROL, EXT, or SHIFT.+-- c is the character to use (a-z, A-Z, 0-9, F1-F24, etc). Note that no spaces are allowed in this string. A good example is+-- \"ALT|CONTROL|F8\". @$OUTDIR@ is used for the working directory. You can change it by using 'setOutPath' before creating+-- the Shortcut. 'Description' should be the description of the shortcut, or comment as it is called under XP.+-- The error flag is set if the shortcut cannot be created (i.e. either of the paths (link or target) does not exist, or some other error).+--+-- > createDirectory "$SMPROGRAMS/My Company"+-- > createShortcut "$SMPROGRAMS/My Company/My Program.lnk"+-- > [Target "$INSTDIR/My Program.exe"+-- > ,Parameters "some command line parameters"+-- > ,IconFile "$INSTDIR/My Program.exe", IconIndex 2+-- > ,StartOptions "SW_SHOWNORMAL"+-- > ,KeyboardShortcut "ALT|CONTROL|SHIFT|F5"+-- > ,Description "a description"]+createShortcut :: Exp FilePath -> [Attrib] -> Action ()+createShortcut name as = do Value name <- name; x <- foldM f def{scFile=name} as; emit $ CreateShortcut x+ where+ f c (Target x) = do Value x <- x; return c{scTarget=x}+ f c (Parameters x) = do Value x <- x; return c{scParameters=x}+ f c (IconFile x) = do Value x <- x; return c{scIconFile=x}+ f c (IconIndex x) = do Value x <- x; return c{scIconIndex=x}+ f c (StartOptions x) = return c{scStartOptions=x}+ f c (KeyboardShortcut x) = return c{scKeyboardShortcut=x}+ f c (Description x) = do Value x <- x; return c{scDescription=x}+ f c x = error $ "Invalid attribute to shortcut: " ++ show x+++page :: Page -> Action ()+page = emit . Page++finishOptions :: FinishOptions+finishOptions = def++unpage :: Page -> Action ()+unpage = emit . Unpage++requestExecutionLevel :: Level -> Action ()+requestExecutionLevel = emit . RequestExecutionLevel++type HWND = Exp Int++hwndParent :: HWND+hwndParent = return $ Value [Builtin "HWNDPARENT"]++findWindow :: Exp String -> Exp String -> Maybe HWND -> Action HWND+findWindow a b c = do+ v <- var+ Value a <- a+ Value b <- b+ c <- maybe (return Nothing) (fmap (Just . fromValue)) c+ emit $ FindWindow v a b c Nothing+ return $ return $ Value $ val v++getDlgItem :: HWND -> Exp Int -> Action HWND+getDlgItem a b = do+ v <- var+ Value a <- a+ Value b <- b+ emit $ GetDlgItem v a b+ return $ return $ Value $ val v++sendMessage :: [Attrib] -> HWND -> Exp Int -> Exp a -> Exp b -> Action (Exp Int)+sendMessage as a b c d = do+ v <- var+ Value a <- a+ Value b <- b+ Value c <- c+ Value d <- d+ as <- return $ foldl f Nothing as+ emit $ SendMessage a b c d v as+ return $ return $ Value $ val v+ where+ f c (Timeout x) = Just x+ f c x = error $ "Invalid attribute to sendMessage: " ++ show x++abort :: Exp String -> Action ()+abort = emit1 Abort++-- | Inject arbitrary text into a non-global section of the script.+unsafeInject :: String -> Action ()+unsafeInject = emit . UnsafeInject++-- | Inject arbitrary text into the script's global header section.+unsafeInjectGlobal :: String -> Action ()+unsafeInjectGlobal = emit . UnsafeInjectGlobal
+ src/Development/NSIS/Type.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Development.NSIS.Type where++import Data.Data++class Default a where def :: a+instance Default (Maybe a) where def = Nothing+instance Default [a] where def = []+++newtype Var = Var Int deriving (Data,Typeable,Eq)+instance Default Var where def = Var 0+instance Show Var where show (Var i) = "$_" ++ show i+++-- | A code label, used for @goto@ programming, see 'Development.NSIS.Sugar.newLabel'.+newtype Label = Label Int deriving (Data,Typeable,Eq)+instance Show Label where show (Label i) = if i == 0 then "0" else "_lbl" ++ show i+++newtype Fun = Fun String deriving (Data,Typeable,Eq,Ord)+instance Show Fun where show (Fun i) = i++newFun :: Int -> Fun+newFun i = Fun $ "_fun" ++ show i++newtype SectionId = SectionId Int deriving (Data,Typeable)+instance Show SectionId where show (SectionId i) = "${_sec" ++ show i ++ "}"+++type Val = [Val_]+data Val_ = Var_ Var | Builtin String | Literal String deriving (Data,Typeable,Eq)++instance Show Val_ where+ show x = show [x]+ showList xs = showString $ "\"" ++ concatMap f xs ++ "\""+ where+ f (Var_ x) = show x+ f (Builtin x) = "$" ++ x+ f (Literal x) = concatMap g x++ g '\"' = "$\\\""+ g '\r' = "$\\r"+ g '\n' = "$\\n"+ g '\t' = "$\\t"+ g '$' = "$$"+ g x = [x]+++data NSIS+ -- primitives+ = Assign Var Val+ | Goto Label+ | Labeled Label++ -- functions and branches+ | StrCmpS Val Val Label Label+ | IntCmp Val Val Label Label Label+ | IntOp Var Val String Val+ | StrCpy Var Val Val Val+ | StrLen Var Val+ | GetFileTime Val Var Var+ | IfErrors Label Label+ | SectionGetText SectionId Var+ | SectionSetText SectionId Val+ | SectionGetFlags SectionId Var+ | SectionSetFlags SectionId Val+ | IfFileExists Val Label Label+ | FindFirst Var Var Val+ | FindNext Val Var+ | FindClose Val+ | Push Val+ | Pop Var++ -- blocks+ | Section ASection [NSIS]+ | SectionGroup ASectionGroup [NSIS]+ | Function Fun [NSIS]+ | Call Fun++ -- Global settings+ | Name Val+ | File AFile+ | OutFile Val+ | InstallDir Val+ | InstallIcon Val+ | UninstallIcon Val+ | HeaderImage (Maybe Val)+ | Page Page+ | Unpage Page++ -- Actions+ | SetOutPath Val+ | CreateDirectory Val+ | SetCompressor ACompressor+ | WriteUninstaller Val+ | FileOpen Var Val FileMode+ | FileWrite Val Val+ | FileClose Val+ | MessageBox [MessageBoxType] Val [(String,Label)]+ | CreateShortcut AShortcut+ | WriteRegStr HKEY Val Val Val+ | WriteRegExpandStr HKEY Val Val Val+ | WriteRegDWORD HKEY Val Val Val+ | ReadRegStr Var HKEY Val Val+ | DeleteRegKey HKEY Val+ | DeleteRegValue HKEY Val Val+ | ReadEnvStr Var Val+ | Exec Val+ | ExecWait Val+ | ExecShell AExecShell+ | ClearErrors+ | Delete ADelete+ | RMDir ARMDir+ | CopyFiles ACopyFiles+ | RequestExecutionLevel Level+ | AddPluginDir Val+ | InstallDirRegKey HKEY Val Val+ | AllowRootDirInstall Bool+ | Caption Val+ | ShowInstDetails Visibility+ | ShowUninstDetails Visibility+ | Unicode Bool+ | SetDetailsPrint DetailsPrint+ | DetailPrint Val+ | Plugin String String [Val]+ | Sleep Val+ | FindWindow Var Val Val (Maybe Val) (Maybe Val)+ | GetDlgItem Var Val Val+ | SendMessage Val Val Val Val Var (Maybe Int)+ | Abort Val++ -- Escape hatch+ | UnsafeInject String+ | UnsafeInjectGlobal String+ deriving (Data,Typeable,Show)++-- | Value to use with 'setDetailsPrint'.+data DetailsPrint = NoDetailsPrint | ListOnly | TextOnly | Both | LastUsed+ deriving (Data,Typeable,Bounded,Enum,Eq,Ord)++instance Show DetailsPrint where+ show NoDetailsPrint = "None"+ show ListOnly = "ListOnly"+ show TextOnly = "TextOnly"+ show Both = "Both"+ show LastUsed = "LastUsed"++-- | Mode to use with 'Development.+data FileMode+ = ModeRead -- ^ Read a file.+ | ModeWrite -- All contents of file are destroyed.+ | ModeAppend -- ^ Opened for both read and write, contents preserved.+ deriving (Data,Typeable,Bounded,Enum,Eq,Ord)+ +instance Show FileMode where+ show ModeRead = "r"+ show ModeWrite = "w"+ show ModeAppend = "a"+++data AShortcut = AShortcut+ {scFile :: Val+ ,scTarget :: Val+ ,scParameters :: Val+ ,scIconFile :: Val+ ,scIconIndex :: Val+ ,scStartOptions :: String+ ,scKeyboardShortcut :: String+ ,scDescription :: Val+ } deriving (Data,Typeable,Show)++instance Default AShortcut where def = AShortcut def def def def def def def def++data ASection = ASection+ {secId :: SectionId+ ,secName :: Val+ ,secDescription :: Val+ ,secBold :: Bool+ ,secRequired :: Bool+ ,secUnselected :: Bool+ } deriving (Data,Typeable,Show)++instance Default ASection where def = ASection (SectionId 0) def def False False False++data ASectionGroup = ASectionGroup+ {secgId :: SectionId+ ,secgName :: Val+ ,secgExpanded :: Bool+ ,secgDescription :: Val+ } deriving (Data,Typeable,Show)++instance Default ASectionGroup where def = ASectionGroup (SectionId 0) def False def++data Compressor = LZMA | ZLIB | BZIP2 deriving (Data,Typeable,Show)++instance Default Compressor where def = ZLIB++data ACompressor = ACompressor + {compType :: Compressor+ ,compSolid :: Bool+ ,compFinal :: Bool+ } deriving (Data,Typeable,Show)++instance Default ACompressor where def = ACompressor def False False++data AFile = AFile+ {filePath :: Val+ ,fileNonFatal :: Bool+ ,fileRecursive :: Bool+ ,fileOName :: Maybe Val+ } deriving (Data,Typeable,Show)++instance Default AFile where def = AFile def False False Nothing++data ARMDir = ARMDir+ {rmDir :: Val+ ,rmRecursive :: Bool+ ,rmRebootOK :: Bool+ } deriving (Data,Typeable,Show)++instance Default ARMDir where def = ARMDir def False False++data ADelete = ADelete+ {delFile :: Val+ ,delRebootOK :: Bool+ } deriving (Data,Typeable,Show)++instance Default ADelete where def = ADelete def False++data AExecShell = AExecShell+ {esCommand :: Val+ ,esShow :: ShowWindow+ } deriving (Data,Typeable,Show)++instance Default AExecShell where def = AExecShell def def++data ACopyFiles = ACopyFiles+ {cpFrom :: Val+ ,cpTo :: Val+ ,cpSilent :: Bool+ ,cpFilesOnly :: Bool+ } deriving (Data,Typeable,Show)++instance Default ACopyFiles where def = ACopyFiles def def False False++data ShowWindow+ = SW_SHOWDEFAULT+ | SW_SHOWNORMAL+ | SW_SHOWMAXIMIZED+ | SW_SHOWMINIMIZED+ | SW_HIDE+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)++instance Default ShowWindow where def = SW_SHOWDEFAULT++data HKEY+ = HKCR | HKEY_CLASSES_ROOT+ | HKLM | HKEY_LOCAL_MACHINE+ | HKCU | HKEY_CURRENT_USER+ | HKU | HKEY_USERS+ | HKCC | HKEY_CURRENT_CONFIG+ | HKDD | HKEY_DYN_DATA+ | HKPD | HKEY_PERFORMANCE_DATA+ | SHCTX | SHELL_CONTEXT+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)++data MessageBoxType+ = MB_OK -- ^ Display with an OK button+ | MB_OKCANCEL -- ^ Display with an OK and a cancel button+ | MB_ABORTRETRYIGNORE -- ^ Display with abort, retry, ignore buttons+ | MB_RETRYCANCEL -- ^ Display with retry and cancel buttons+ | MB_YESNO -- ^ Display with yes and no buttons+ | MB_YESNOCANCEL -- ^ Display with yes, no, cancel buttons+ | MB_ICONEXCLAMATION -- ^ Display with exclamation icon+ | MB_ICONINFORMATION -- ^ Display with information icon+ | MB_ICONQUESTION -- ^ Display with question mark icon+ | MB_ICONSTOP -- ^ Display with stop icon+ | MB_USERICON -- ^ Display with installer's icon+ | MB_TOPMOST -- ^ Make messagebox topmost+ | MB_SETFOREGROUND -- ^ Set foreground+ | MB_RIGHT -- ^ Right align text+ | MB_RTLREADING -- ^ RTL reading order+ | MB_DEFBUTTON1 -- ^ Button 1 is default+ | MB_DEFBUTTON2 -- ^ Button 2 is default+ | MB_DEFBUTTON3 -- ^ Button 3 is default+ | MB_DEFBUTTON4 -- ^ Button 4 is default+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)+instance Default MessageBoxType where def = MB_ICONINFORMATION+++data Page+ = License FilePath+ | Components+ | Directory+ | InstFiles+ | Confirm+ | Finish FinishOptions+ deriving (Show,Data,Typeable,Eq)++data FinishOptions = FinishOptions+ {finRun :: String+ ,finRunText :: String+ ,finRunParamters :: String+ ,finRunChecked :: Bool+ ,finReadme :: String+ ,finReadmeText :: String+ ,finReadmeChecked :: Bool+ ,finLink :: String+ ,finLinkText :: String+ } deriving (Data,Typeable,Show,Eq)++instance Default FinishOptions where def = FinishOptions "" "" "" True "" "" True "" ""+++showPageCtor :: Page -> String+showPageCtor (License _) = "License"+showPageCtor (Finish _) = "Finish"+showPageCtor x = show x++data Level = None | User | Highest | Admin+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)++data Visibility = Hide | Show | NeverShow+ deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord)
+ test/Examples/Base64.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Base64(base64) where++import Development.NSIS+import Development.NSIS.Plugins.Base64+++base64 = do+ name "base64"+ allowRootDirInstall True+ outFile "base64.exe"+ caption "Base64 test"+ showInstDetails Show+ installDir "$EXEDIR"+ requestExecutionLevel User+ addPluginDir "."++ page Directory+ page InstFiles++ section "" [] $ do+ setOutPath "$INSTDIR"+ let src = "Hello NSIS Plugin!"+ enc <- constant_ $ encrypt src+ dec <- constant_ $ decrypt enc+ alert $ "Source: " & src & "\nEncrypted: " & enc & "\nDecrypted: " & dec
+ test/Examples/EnvVarUpdate.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.EnvVarUpdate(envvarupdate) where++import Development.NSIS+import Development.NSIS.Plugins.EnvVarUpdate+++envvarupdate = do+ name "envvarupdate"+ outFile "envvarupdate.exe"+ requestExecutionLevel User++ section "" [] $ do+ let assert x = iff_ (getEnvVar HKCU "NSIS_TEST" %/= x) $ alert $ "FAILED!"+ deleteEnvVar HKCU "NSIS_TEST"+ setEnvVar HKCU "NSIS_TEST" "This is a;test"+ assert "This is a;test"+ setEnvVarAppend HKCU "NSIS_TEST" "foo bar"+ assert "This is a;test;foo bar"+ setEnvVarPrepend HKCU "NSIS_TEST" "test"+ assert "test;This is a;foo bar"+ setEnvVarRemove HKCU "NSIS_TEST" "test"+ assert "This is a;foo bar"+ setEnvVarRemove HKCU "NSIS_TEST" "foo bar"+ assert "This is a"+ setEnvVarPrepend HKCU "NSIS_TEST" "extra"+ assert "extra;This is a"+ setEnvVarRemove HKCU "NSIS_TEST" "bob"+ assert "extra;This is a"+ setEnvVar HKCU "NSIS_TEST" "bob;bob;bob;x;bob"+ setEnvVarRemove HKCU "NSIS_TEST" "bob"+ assert "x"+ setEnvVarRemove HKCU "NSIS_TEST" "x"+ assert ""+ setEnvVar HKCU "NSIS_TEST" "y"+ deleteEnvVar HKCU "NSIS_TEST"+ assert ""++ alert $ "USER $$PATH = " & getEnvVar HKCU "PATH"+ alert $ "MACHINE $$PATH = " & getEnvVar HKLM "PATH"++ alert "Expecting to abort with a String limit error"+ deleteEnvVar HKCU "NSIS_TEST"+ val <- mutable_ "This is a test that will overflow at some point"+ i <- mutable_ 0+ while (i %< 100) $ do+ i @= i + 1+ val @= val & val+ setEnvVar HKCU "NSIS_TEST" val+ alert "Failed test, should have got a string limit error"
+ test/Examples/Example1.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Example1(example1) where++import Development.NSIS+++-- Based on example1.nsi from NSIS+--+-- This script is perhaps one of the simplest NSIs you can make. All of the+-- optional settings are left to their default settings. The installer simply +-- prompts the user asking them where to install, and drops a copy of example1.hs+-- there. +example1 = do+ + -- The name of the installer+ name "Example1"++ -- The file to write+ outFile "example1.exe"++ -- The default installation directory+ installDir "$DESKTOP/Example1"++ -- Request application privileges for Windows Vista+ requestExecutionLevel User++ ---------------------------------++ -- Pages+ + page Directory+ page InstFiles++ ---------------------------------++ -- The stuff to install+ section "" [] $ do -- No components page, name is not important++ -- Set output path to the installation directory.+ setOutPath "$INSTDIR"++ -- Put file there+ file [] "test/Examples/Example1.hs"
+ test/Examples/Example2.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Example2(example2) where++import Development.NSIS++-- Based on example2.nsi from NSIS+--+-- This script is based on example1.nsi, but it remember the directory, +-- has uninstall support and (optionally) installs start menu shortcuts.+--+-- It will install example2.nsi into a directory that the user selects,++----------------------------------++example2 = do+ -- The name of the installer+ _ <- constantStr "Ex" "2"++ name "Example$Ex"++ -- The file to write+ outFile "example$Ex.exe"++ -- The default installation directory+ installDir "$PROGRAMFILES64/Example2"++ -- Registry key to check for directory (so if you install again, it will + -- overwrite the old one automatically)+ installDirRegKey HKLM "Software/NSIS_Example2" "Install_Dir"++ -- Request application privileges for Windows Vista+ requestExecutionLevel Admin++ -- Inject a literal setting that's not currently supported by the DSL+ unsafeInjectGlobal "# ignore me (could be an injected literal)"++ ----------------------------------++ -- Pages++ page Components+ page Directory+ page InstFiles++ unpage Confirm+ unpage InstFiles++ ----------------------------------++ -- The stuff to install+ section "Example2 (required)" [Required] $ do++ -- Set output path to the installation directory.+ setOutPath "$INSTDIR"++ -- Put file there+ file [] "test/Examples/Example$Ex.hs"++ -- Inject a non-global literal setting+ unsafeInject "# ignore me (could be an injected literal)"++ -- Write the installation path into the registry+ writeRegStr HKLM "SOFTWARE/NSIS_Example2" "Install_Dir" "$INSTDIR"++ -- Write the uninstall keys for Windows+ writeRegStr HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "DisplayName" "NSIS Example2"+ writeRegStr HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "UninstallString" "\"$INSTDIR/uninstall.exe\""+ writeRegDWORD HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "NoModify" 1+ writeRegDWORD HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2" "NoRepair" 1+ writeUninstaller "uninstall.exe"++ -- Optional section (can be disabled by the user)+ section "Start Menu Shortcuts" [] $ do++ createDirectory "$SMPROGRAMS/Example2"+ createShortcut "$SMPROGRAMS/Example2/Uninstall.lnk" [Target "$INSTDIR/uninstall.exe", IconFile "$INSTDIR/uninstall.exe", IconIndex 0]+ createShortcut "$SMPROGRAMS/Example2/Example2 (MakeNSISW).lnk" [Target "$INSTDIR/example2.nsi", IconFile "$INSTDIR/example2.nsi", IconIndex 0]++ ----------------------------------++ -- Uninstaller++ uninstall $ do++ -- Remove registry keys+ deleteRegKey HKLM "Software/Microsoft/Windows/CurrentVersion/Uninstall/Example2"+ deleteRegKey HKLM "SOFTWARE/NSIS_Example2"++ -- Remove files and uninstaller+ delete [] "$INSTDIR/example2.nsi"+ delete [] "$INSTDIR/uninstall.exe"++ -- Remove shortcuts, if any+ delete [] "$SMPROGRAMS/Example2/*.*"++ -- Remove directories used+ rmdir [] "$SMPROGRAMS/Example2"+ rmdir [] "$INSTDIR"
+ test/Examples/Finish.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Finish(finish) where++import Development.NSIS+++finish = do+ name "Finish"+ outFile "finish.exe"+ requestExecutionLevel User+ installDir "$DESKTOP"++ page Directory+ page InstFiles+ page $ Finish finishOptions+ {finRun="$WINDIR/notepad.exe"+ ,finRunText="Run Notepad"+ ,finLink="http://google.com/"+ ,finLinkText="Visit Google!"+ }++ section "" [] $ return ()
+ test/Examples/Primes.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Primes(primes) where++import Development.NSIS++-- Based on primes.nsi from NSIS+--+-- This is an example of the possibities of the NSIS Script language.+-- It calculates prime numbers.++----------------------------------++primes = do++ name "primes"+ allowRootDirInstall True+ outFile "primes.exe"+ caption "Prime number generator"+ showInstDetails Show+ installDir "$EXEDIR"+ requestExecutionLevel User++ ----------------------------------++ --Pages++ page Directory+ page InstFiles++ ----------------------------------++ section "" [] $ do+ setOutPath "$INSTDIR"+ hideProgress doPrimes+++doPrimes = do+ hdl <- fileOpen ModeWrite "$INSTDIR/primes.txt"++ let output x = do+ detailPrint $ strShow x & " is prime!"+ fileWrite hdl $ strShow x & " is prime!\r\n"+ output 2+ output 3++ ppos <- mutableInt "PPOS" 5 -- position in prime searching+ pdiv <- mutableInt "PDIV" 0 -- divisor+ pcnt <- mutableInt "PCNT" 2 -- count of how many we've printed+ loop $ \breakOuter -> do+ pdiv @= 3+ loop $ \breakInner -> do+ iff_ (ppos `mod` pdiv %== 0) $ do+ ppos @= ppos + 2+ breakInner+ pdiv @= pdiv + 2+ iff_ (pdiv %>= ppos) $ do+ output ppos+ pcnt @= pcnt + 1+ iff_ (pcnt %== 100) $ do+ pcnt @= 0+ ans <- messageBox [MB_YESNO] "Process more?"+ iff_ (ans %== "NO")+ breakOuter++ fileClose hdl
+ test/Examples/Radio.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Radio(radio) where++import Development.NSIS+import Development.NSIS.Plugins.EnvVarUpdate+import Development.NSIS.Plugins.Sections+++radio = do+ name "Radio"+ outFile "radio.exe"+ installDir "$DESKTOP/Radio"+ requestExecutionLevel User++ -- page Directory+ page Components+ page InstFiles++ section "Core files" [Required] $ do+ setOutPath "$INSTDIR"+ file [] "test/Examples/Radio.hs"++ local <- section "Add to user %PATH%" [] $ do+ setEnvVarPrepend HKCU "PATH" "$INSTDIR"+ global <- section "Add to system %PATH%" [] $ do+ setEnvVarPrepend HKLM "PATH" "$INSTDIR"+ atMostOneSection [local,global]++ a <- section "I like Marmite" [] $ return ()+ b <- section "I hate Marmite" [] $ return ()+ c <- section "I don't care" [] $ return ()+ exactlyOneSection [a,b,c]
+ test/Examples/Taskbar.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.Taskbar(taskbar) where++import Control.Monad+import Development.NSIS+import qualified Development.NSIS.Plugins.Taskbar as T+++taskbar = do+ name "taskbar"+ allowRootDirInstall True+ outFile "taskbar.exe"+ caption "Taskbar test"+ showInstDetails Show+ installDir "$EXEDIR"+ requestExecutionLevel User+ addPluginDir "."+ T.taskbar++ page Directory+ page InstFiles++ section "" [] $+ replicateM_ 20 $ do+ sleep 100+ detailPrint "hello"
+ test/Examples/WinMessages.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Examples.WinMessages(winmessages) where++import Development.NSIS+import Development.NSIS.Plugins.WinMessages+++winmessages = do+ name "winmessages"+ outFile "winmessages.exe"+ requestExecutionLevel User++ section "" [] $ do+ wnd <- findWindow "#32770" "" (Just hwndParent)+ ctl <- getDlgItem wnd 1027+ _ <- sendMessage [] ctl wm_SETTEXT (0 :: Exp Int) ("STR:MyText" :: Exp String)+ return ()++{-+Section+ FindWindow $0 '#32770' '' $HWNDPARENT+ GetDlgItem $1 $0 1027+ SendMessage $1 ${WM_SETTEXT} 0 'STR:MyText'+SectionEnd+-}
+ test/Main.hs view
@@ -0,0 +1,67 @@++module Main(main) where++import Control.Monad+import Data.List+import Data.Maybe+import System.Process+import System.Directory+import System.Environment+import System.Exit++import Development.NSIS+import Examples.Base64+import Examples.Example1+import Examples.Example2+import Examples.Finish+import Examples.Primes+import Examples.Radio+import Examples.Taskbar+import Examples.WinMessages+import Examples.EnvVarUpdate+++examples = let (*) = (,) in+ ["example1" * void example1, "example2" * void example2, "base64" * void base64+ ,"finish" * void finish, "primes" * void primes, "radio" * void radio, "taskbar" * void taskbar+ ,"winmessages" * void winmessages, "envvarupdate" * void envvarupdate]+++main = do+ args <- getArgs+ let (flags,names) = partition ("-" `isPrefixOf`) args+ when ("--help" `elem` flags) $ do+ putStr $ unlines+ ["nsis-test [FLAGS] [EXAMPLES]"+ ,"Examples:"+ ," " ++ unwords (map fst examples)+ ,"Flags:"+ ," --help Show this message"+ ," --nowrite Don't write out the scripts"+ ," --nobuild Don't build"+ ," --build Do build"+ ," --run Run the result"+ ]+ exitSuccess+ when (null args) $ do+ putStrLn "*****************************************************************"+ putStrLn "** Running nsis test suite, run with '--help' to see arguments **"+ putStrLn "*****************************************************************"+ names <- return $ if null names then map fst examples else names++ b <- findExecutable "makensis"+ let build | "--build" `elem` flags = True+ | "--nobuild" `elem` flags = False+ | otherwise = isJust b++ forM_ names $ \name -> do+ let script = fromMaybe (error $ "Unknown example: " ++ name) $ lookup name examples+ unless ("--nowrite" `elem` flags) $ writeFile (name ++ ".nsi") $ nsis script+ when build $ do+ r <- system $ "makensis -V3 " ++ name ++ ".nsi"+ when (r /= ExitSuccess) $ error "NSIS FAILED"+ when ("--run" `elem` flags) $ do+ system $ name ++ ".exe"+ return ()+ when (isNothing b) $+ putStrLn "Warning: No nsis on the PATH, files were not built"