diff --git a/Development/NSIS.hs b/Development/NSIS.hs new file mode 100644 --- /dev/null +++ b/Development/NSIS.hs @@ -0,0 +1,69 @@ +{-# 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. +-- +-- For examples, see the Examples source directory. +-- +-- Much of the documentation from the Installer section is taken straight 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 + (%==), (%/=), (%<=), (%<), (%>=), (%>), + true, false, not_, + strRead, strShow, + (&), strConcat, strLength, strTake, strDrop, strReplace, strIsPrefixOf, strUnlines, + -- ** File system manipulation + FileHandle, fileOpen, fileWrite, fileClose, withFile', writeFile', writeFileLines, + rmdir, delete, + getFileTime, fileExists, findEach, findOnce, + createDirectory, createShortcut, + -- ** Registry manipulation + readRegStr, deleteRegKey, writeRegStr, writeRegDWORD, + -- ** Process execution + exec, + -- * Installer + -- ** Global installer options + name, outFile, installDir, setCompressor, + installIcon, uninstallIcon, headerImage, + installDirRegKey, allowRootDirInstall, caption, showInstDetails, showUninstDetails, + -- ** Sections + SectionId, section, sectionGroup, newSectionId, sectionSetText, sectionGetText, uninstall, page, unpage, + -- ** Section commands + file, alwaysNonFatal, writeUninstaller, alert, setOutPath, messageBox, requestExecutionLevel, + hideProgress, detailPrint, + -- * Settings + Compressor(..), HKEY(..), MessageBoxType(..), Attrib(..), Page(..), Level(..), Visibility(..), + FileMode(..) + ) where + +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. +nsis :: Action () -> String +nsis = unlines . showNSIS . optimise . runAction + + +-- | 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 (but please do report any such bugs!). +nsisNoOptimise :: Action () -> String +nsisNoOptimise = unlines . showNSIS . runAction diff --git a/Development/NSIS/Library.hs b/Development/NSIS/Library.hs new file mode 100644 --- /dev/null +++ b/Development/NSIS/Library.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Development.NSIS.Library where + +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 + + +-- | 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 %== strTake (strLength 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 = writeFile' a $ strUnlines b + + +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 new file mode 100644 --- /dev/null +++ b/Development/NSIS/Optimise.hs @@ -0,0 +1,161 @@ +{-# 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 = transform f x + where + f (Labeled x:xs) = Labeled x : xs + f (x:xs) | null (children x :: [NSIS]) = transformBi moveBounce x : xs + f x = 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/Show.hs b/Development/NSIS/Show.hs new file mode 100644 --- /dev/null +++ b/Development/NSIS/Show.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE RecordWildCards #-} + +module Development.NSIS.Show(showNSIS) where + +import Development.NSIS.Type +import Data.Generics.Uniplate.Data +import Data.Char +import Data.List + + +showNSIS :: [NSIS] -> [String] +showNSIS xs = + ["!Include MUI2.nsh"] ++ + ["Var _" ++ show v | v <- sort $ nub [i | Var i <- universeBi xs]] ++ + outs (filter isGlobal xs) ++ + ["!insertmacro MUI_LANGUAGE \"English\""] ++ + concat [("Function " ++ show name) : map indent (outs body) ++ ["FunctionEnd"] | Function name body <- universeBi xs] ++ + outs (filter isSection xs) ++ + ["Function .onInit" | not $ null inits] ++ + map indent (outs inits) ++ + ["FunctionEnd" | not $ null inits] ++ + (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 + + +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 + InstallDirRegKey{} -> True + AllowRootDirInstall{} -> True + ShowInstDetails{} -> True + ShowUninstDetails{} -> True + Caption{} -> True + _ -> False + +isSection :: NSIS -> Bool +isSection x = case x of + Section{} -> True + SectionGroup{} -> True + _ -> False + + +outs :: [NSIS] -> [String] +outs = concatMap out + +out :: NSIS -> [String] +out (Assign v x) = ["StrCpy " ++ show v ++ " " ++ show x] +out (SetCompressor ACompressor{..}) = [unwords $ "SetCompressor" : ["/solid"|compSolid] ++ ["/final"|compFinal] ++ [map toLower $ show compType]] +out (Section ASection{secId=SectionId secId, ..} xs) = + [unwords $ "Section" : ["/o"|secUnselected] ++ [show $ [Literal "!"|secBold] ++ secName, "_sec" ++ show secId]] ++ + map indent (["SectionIn RO" | secRequired] ++ outs xs) ++ + ["SectionEnd"] +out (SectionGroup ASectionGroup{secgId=SectionId secgId, ..} xs) = + [unwords $ "SectionGroup" : ["/e"|secgExpanded] ++ [show secgName, "_sec" ++ show secgId]] ++ + map indent (outs xs) ++ + ["SectionGroupEnd"] +out (File AFile{..}) = [unwords $ "File" : ["/nonfatal"|fileNonFatal] ++ ["/r"|fileRecursive] ++ [show filePath]] +out (Labeled i) = [show i ++ ":"] +out (CreateShortcut AShortcut{..}) = return $ unwords $ + ["CreateShortcut", show scFile, show scTarget, show scParameters, show scIconFile + ,show scIconIndex, show scStartOptions, show scKeyboardShortcut, show scDescription] +out (InstallIcon x) = ["!define MUI_ICON " ++ show x] +out (UninstallIcon x) = ["!define MUI_UNICON " ++ show x] +out (HeaderImage x) = "!define MUI_HEADERIMAGE" : ["!define MUI_HEADERIMAGE_BITMAP " ++ show x | Just x <- [x]] +out (Page x) = ["!insertmacro MUI_PAGE_" ++ map toUpper (show x)] +out (Unpage x) = ["!insertmacro MUI_UNPAGE_" ++ map toUpper (show x)] +out Function{} = [] +out (Delete ADelete{..}) = [unwords $ "Delete" : ["/rebootok"|delRebootOK] ++ [show delFile]] +out (RMDir ARMDir{..}) = [unwords $ "RMDir" : ["/r"|rmRecursive] ++ ["/rebootok"|rmRebootOK] ++ [show rmDir]] +out (MessageBox flags txt lbls) = [unwords $ "MessageBox" : intercalate "|" (map show flags) : show txt : + ["ID" ++ a ++ " " ++ show b | (a,b) <- lbls]] +out (Goto x) = ["Goto " ++ show x | x /= Label 0] + +out x = [show x] + + +indent x = " " ++ x diff --git a/Development/NSIS/Sugar.hs b/Development/NSIS/Sugar.hs new file mode 100644 --- /dev/null +++ b/Development/NSIS/Sugar.hs @@ -0,0 +1,897 @@ +{-# LANGUAGE OverloadedStrings, EmptyDataDecls, ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Development.NSIS.Sugar( + Compressor(..), HKEY(..), MessageBoxType(..), Page(..), Level(..), Visibility(..), FileMode(..), + 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.Typeable +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) + + +-- | 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" + + +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 [] = [] + +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 x <- x; return $ return x + +-- | 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"] + + +-- | 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 + +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] + +sectionGetText :: SectionId -> Exp String +sectionGetText x = do v <- var; emit $ SectionGetText x v; return $ Value $ val v + +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) + + +--------------------------------------------------------------------- +-- ATTRIBUTES + +data Attrib + = Solid + | Final + | RebootOK + | 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 + 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 + + +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 + + +-- If you jump from inside the loop to outside then you may leak a find 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 + + +-- return either "" for no patterns matched, or the first file +findOnce :: Exp FilePath -> Exp String +findOnce spec = do + -- can't use findEach + jump since then we leak a find handle + Value spec <- spec + hdl <- var + v <- var + emit $ FindFirst hdl v spec + emit $ FindClose $ val hdl + return $ Value $ val v + + +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'. +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) + + +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 + +sectionSetText :: SectionId -> Exp String -> Action () +sectionSetText x = emit1 $ SectionSetText x + +-- 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 + +writeRegDWORD :: HKEY -> Exp String -> Exp String -> Exp Int -> Action () +writeRegDWORD k = emit3 $ WriteRegDWORD k + +hideProgress :: Action a -> Action a +hideProgress act = do + fun <- fmap Fun unique + (xs, v) <- capture act + emit $ Function fun xs + emit $ Call fun + return v + +allowRootDirInstall :: Bool -> Action () +allowRootDirInstall = emit . AllowRootDirInstall + +caption :: Exp String -> Action () +caption = emit1 Caption + +detailPrint :: Exp String -> Action () +detailPrint = emit1 DetailPrint + +showInstDetails :: Visibility -> Action () +showInstDetails = emit . ShowInstDetails + +showUninstDetails :: Visibility -> Action () +showUninstDetails = emit . ShowUninstDetails + + +-- | 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 $ foldl f def{filePath=x} as + where + f c Recursive = c{fileRecursive=True} + f c NonFatal = c{fileNonFatal=True} + f c x = error $ "Invalid attribute to file: " ++ show x + +section :: Exp String -> [Attrib] -> Action () -> Action () +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 + 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 () +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 + 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 = section "Uninstall" [] + +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 + +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 + +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 + +unpage :: Page -> Action () +unpage = emit . Unpage + +requestExecutionLevel :: Level -> Action () +requestExecutionLevel = emit . RequestExecutionLevel diff --git a/Development/NSIS/Type.hs b/Development/NSIS/Type.hs new file mode 100644 --- /dev/null +++ b/Development/NSIS/Type.hs @@ -0,0 +1,242 @@ +{-# 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 Int deriving (Data,Typeable) +instance Show Fun where show (Fun i) = "_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 + | IfFileExists Val Label Label + | FindFirst Var Var Val + | FindNext Val Var + | FindClose Val + + -- 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 + | WriteRegDWORD HKEY Val Val Val + | ReadRegStr Var HKEY Val Val + | DeleteRegKey HKEY Val + | Exec Val + | ClearErrors + | Delete ADelete + | RMDir ARMDir + | RequestExecutionLevel Level + | InstallDirRegKey HKEY Val Val + | AllowRootDirInstall Bool + | Caption Val + | ShowInstDetails Visibility + | ShowUninstDetails Visibility + | DetailPrint Val + deriving (Data,Typeable,Show) + +-- | 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 + } deriving (Data,Typeable,Show) + +instance Default AFile where def = AFile def False False + +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 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 + | Components + | Directory + | InstFiles + | Confirm + deriving (Show,Data,Typeable,Read,Bounded,Enum,Eq,Ord) + +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/Example1.hs b/Examples/Example1.hs new file mode 100644 --- /dev/null +++ b/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 [] "Examples/Example1.hs" diff --git a/Examples/Example2.hs b/Examples/Example2.hs new file mode 100644 --- /dev/null +++ b/Examples/Example2.hs @@ -0,0 +1,91 @@ +{-# 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 + name "Example2" + + -- The file to write + outFile "example2.exe" + + -- The default installation directory + installDir "$PROGRAMFILES/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 + + ---------------------------------- + + -- 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/Example2.hs" + + -- 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/Primes.hs b/Examples/Primes.hs new file mode 100644 --- /dev/null +++ b/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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,35 @@ + +module Main where + +import Control.Monad +import Data.List +import Data.Maybe +import System.Cmd +import System.Environment +import System.Exit + +import Development.NSIS +import Examples.Example1 +import Examples.Example2 +import Examples.Primes + + +examples = let (*) = (,) in ["example1" * example1, "example2" * example2, "primes" * primes] + + +main = do + args <- getArgs + let (flags,names) = partition ("-" `isPrefixOf`) args + names <- return $ concatMap (\x -> if x == "all" then map fst examples else [x]) names + if null names then + putStrLn $ "Type the name of an example: " ++ unwords (map fst examples) + else do + forM_ names $ \name -> do + let script = fromMaybe (error $ "Unknown example: " ++ name) $ lookup name examples + unless ("--nowrite" `elem` flags) $ writeFile (name ++ ".nsi") $ nsis script + unless ("--nobuild" `elem` flags) $ do + r <- system $ "\"C:/Program Files/NSIS/makensis.exe\" " ++ name ++ ".nsi" + when (r /= ExitSuccess) $ error "NSIS FAILED" + when ("--run" `elem` flags) $ do + system $ name ++ ".exe" + return () diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/nsis.cabal b/nsis.cabal new file mode 100644 --- /dev/null +++ b/nsis.cabal @@ -0,0 +1,54 @@ +cabal-version: >= 1.6 +build-type: Simple +name: nsis +version: 0.1 +-- license is GPL v2 only +license: GPL +license-file: LICENSE +category: Development +author: Neil Mitchell +maintainer: Neil Mitchell +copyright: Neil Mitchell 2012 +synopsis: Build NSIS Installers +description: + Helps writing NSIS Installers, see . +homepage: http://community.haskell.org/~ndm/nsis/ +stability: Beta + +source-repository head + type: darcs + location: http://community.haskell.org/~ndm/darcs/nsis/ + +library + build-depends: + base == 4.*, + transformers == 0.2.*, + uniplate >= 1.5 && < 1.7 + + exposed-modules: + Development.NSIS + other-modules: + Development.NSIS.Library + Development.NSIS.Optimise + Development.NSIS.Show + Development.NSIS.Sugar + Development.NSIS.Type + +flag testprog + default: False + description: Build the test program + + +executable nsis + main-is: Main.hs + if flag(testprog) + buildable: True + else + buildable: False + build-depends: + process + + other-modules: + Examples.Example1 + Examples.Example2 + Examples.Primes