diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -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
diff --git a/Development/NSIS.hs b/Development/NSIS.hs
deleted file mode 100644
--- a/Development/NSIS.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | NSIS (Nullsoft Scriptable Install System, ) 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
diff --git a/Development/NSIS/Library.hs b/Development/NSIS/Library.hs
deleted file mode 100644
--- a/Development/NSIS/Library.hs
+++ /dev/null
@@ -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 .
---
--- 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
diff --git a/Development/NSIS/Optimise.hs b/Development/NSIS/Optimise.hs
deleted file mode 100644
--- a/Development/NSIS/Optimise.hs
+++ /dev/null
@@ -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
diff --git a/Development/NSIS/Plugins/Base64.hs b/Development/NSIS/Plugins/Base64.hs
deleted file mode 100644
--- a/Development/NSIS/Plugins/Base64.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-
--- | Base64 plugin:
-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
diff --git a/Development/NSIS/Plugins/EnvVarUpdate.hs b/Development/NSIS/Plugins/EnvVarUpdate.hs
deleted file mode 100644
--- a/Development/NSIS/Plugins/EnvVarUpdate.hs
+++ /dev/null
@@ -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
diff --git a/Development/NSIS/Plugins/Sections.hs b/Development/NSIS/Plugins/Sections.hs
deleted file mode 100644
--- a/Development/NSIS/Plugins/Sections.hs
+++ /dev/null
@@ -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
-
diff --git a/Development/NSIS/Plugins/Taskbar.hs b/Development/NSIS/Plugins/Taskbar.hs
deleted file mode 100644
--- a/Development/NSIS/Plugins/Taskbar.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
--- | Windows 7 Taskbar Progress plugin:
-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" []
diff --git a/Development/NSIS/Plugins/WinMessages.hs b/Development/NSIS/Plugins/WinMessages.hs
deleted file mode 100644
--- a/Development/NSIS/Plugins/WinMessages.hs
+++ /dev/null
@@ -1,566 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-|
-List of common Windows Messages
-
-2005 Shengalts Aleksander aka Instructor
-
-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
diff --git a/Development/NSIS/Show.hs b/Development/NSIS/Show.hs
deleted file mode 100644
--- a/Development/NSIS/Show.hs
+++ /dev/null
@@ -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
diff --git a/Development/NSIS/Sugar.hs b/Development/NSIS/Sugar.hs
deleted file mode 100644
--- a/Development/NSIS/Sugar.hs
+++ /dev/null
@@ -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
diff --git a/Development/NSIS/Type.hs b/Development/NSIS/Type.hs
deleted file mode 100644
--- a/Development/NSIS/Type.hs
+++ /dev/null
@@ -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)
diff --git a/Examples/Base64.hs b/Examples/Base64.hs
deleted file mode 100644
--- a/Examples/Base64.hs
+++ /dev/null
@@ -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
diff --git a/Examples/EnvVarUpdate.hs b/Examples/EnvVarUpdate.hs
deleted file mode 100644
--- a/Examples/EnvVarUpdate.hs
+++ /dev/null
@@ -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"
diff --git a/Examples/Example1.hs b/Examples/Example1.hs
deleted file mode 100644
--- a/Examples/Example1.hs
+++ /dev/null
@@ -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"
diff --git a/Examples/Example2.hs b/Examples/Example2.hs
deleted file mode 100644
--- a/Examples/Example2.hs
+++ /dev/null
@@ -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"
diff --git a/Examples/Finish.hs b/Examples/Finish.hs
deleted file mode 100644
--- a/Examples/Finish.hs
+++ /dev/null
@@ -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 ()
diff --git a/Examples/Primes.hs b/Examples/Primes.hs
deleted file mode 100644
--- a/Examples/Primes.hs
+++ /dev/null
@@ -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
diff --git a/Examples/Radio.hs b/Examples/Radio.hs
deleted file mode 100644
--- a/Examples/Radio.hs
+++ /dev/null
@@ -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]
diff --git a/Examples/Taskbar.hs b/Examples/Taskbar.hs
deleted file mode 100644
--- a/Examples/Taskbar.hs
+++ /dev/null
@@ -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"
diff --git a/Examples/WinMessages.hs b/Examples/WinMessages.hs
deleted file mode 100644
--- a/Examples/WinMessages.hs
+++ /dev/null
@@ -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
--}
diff --git a/Main.hs b/Main.hs
deleted file mode 100644
--- a/Main.hs
+++ /dev/null
@@ -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"
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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:
diff --git a/nsis.cabal b/nsis.cabal
--- a/nsis.cabal
+++ b/nsis.cabal
@@ -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
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, ) 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,
diff --git a/src/Development/NSIS.hs b/src/Development/NSIS.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | NSIS (Nullsoft Scriptable Install System, ) 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
diff --git a/src/Development/NSIS/Library.hs b/src/Development/NSIS/Library.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Library.hs
@@ -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 .
+--
+-- 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
diff --git a/src/Development/NSIS/Optimise.hs b/src/Development/NSIS/Optimise.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Optimise.hs
@@ -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
diff --git a/src/Development/NSIS/Plugins/Base64.hs b/src/Development/NSIS/Plugins/Base64.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Plugins/Base64.hs
@@ -0,0 +1,19 @@
+
+-- | Base64 plugin:
+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
diff --git a/src/Development/NSIS/Plugins/EnvVarUpdate.hs b/src/Development/NSIS/Plugins/EnvVarUpdate.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Plugins/EnvVarUpdate.hs
@@ -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
diff --git a/src/Development/NSIS/Plugins/Sections.hs b/src/Development/NSIS/Plugins/Sections.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Plugins/Sections.hs
@@ -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
+
diff --git a/src/Development/NSIS/Plugins/Taskbar.hs b/src/Development/NSIS/Plugins/Taskbar.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Plugins/Taskbar.hs
@@ -0,0 +1,10 @@
+
+-- | Windows 7 Taskbar Progress plugin:
+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" []
diff --git a/src/Development/NSIS/Plugins/WinMessages.hs b/src/Development/NSIS/Plugins/WinMessages.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Plugins/WinMessages.hs
@@ -0,0 +1,566 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-|
+List of common Windows Messages
+
+2005 Shengalts Aleksander aka Instructor
+
+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
diff --git a/src/Development/NSIS/Show.hs b/src/Development/NSIS/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Show.hs
@@ -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
diff --git a/src/Development/NSIS/Sugar.hs b/src/Development/NSIS/Sugar.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Sugar.hs
@@ -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
diff --git a/src/Development/NSIS/Type.hs b/src/Development/NSIS/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/NSIS/Type.hs
@@ -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)
diff --git a/test/Examples/Base64.hs b/test/Examples/Base64.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Base64.hs
@@ -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
diff --git a/test/Examples/EnvVarUpdate.hs b/test/Examples/EnvVarUpdate.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/EnvVarUpdate.hs
@@ -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"
diff --git a/test/Examples/Example1.hs b/test/Examples/Example1.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Example1.hs
@@ -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"
diff --git a/test/Examples/Example2.hs b/test/Examples/Example2.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Example2.hs
@@ -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"
diff --git a/test/Examples/Finish.hs b/test/Examples/Finish.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Finish.hs
@@ -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 ()
diff --git a/test/Examples/Primes.hs b/test/Examples/Primes.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Primes.hs
@@ -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
diff --git a/test/Examples/Radio.hs b/test/Examples/Radio.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Radio.hs
@@ -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]
diff --git a/test/Examples/Taskbar.hs b/test/Examples/Taskbar.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Taskbar.hs
@@ -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"
diff --git a/test/Examples/WinMessages.hs b/test/Examples/WinMessages.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/WinMessages.hs
@@ -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
+-}
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -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"