bamse 0.9.3 → 0.9.4
raw patch · 45 files changed
+1996/−1218 lines, 45 filesdep +HUnitdep +QuickCheckdep +filepathdep −haskell98dep ~combuild-type:Customnew-component:exe:bamseGennew-component:exe:hsDotnetGennew-component:exe:runTestsbinary-added
Dependencies added: HUnit, QuickCheck, filepath, old-time, process, regex-compat
Dependencies removed: haskell98
Dependency ranges changed: com
Files
- Bamse/Builder.hs +54/−33
- Bamse/DiaWriter.hs +114/−32
- Bamse/DialogUtils.hs +63/−14
- Bamse/GhcPackage.hs +17/−2
- Bamse/IMonad.hs +13/−0
- Bamse/MSIExtra.hs +2/−2
- Bamse/MSITable.hs +2/−1
- Bamse/Options.hs +105/−87
- Bamse/Package.hs +80/−9
- Bamse/PackageGen.hs +183/−82
- Bamse/PackageUtils.hs +73/−13
- Bamse/Util/Dir.hs +120/−0
- Bamse/Util/GetOpts.hs +206/−0
- Bamse/Util/List.hs +96/−0
- Bamse/WindowsInstaller.hs +1/−1
- Bamse/Writer.hs +69/−60
- Main.hs +16/−6
- System/Path.hs +0/−45
- Util/Dir.hs +0/−120
- Util/GetOpts.hs +0/−206
- Util/List.hs +0/−97
- Util/Path.hs +0/−256
- bamse.cabal +72/−11
- examples/Cabal.hs +150/−0
- examples/README +20/−0
- templates/Alex.hs +16/−7
- templates/Bamse.hs +21/−13
- templates/Base.hs +15/−4
- templates/ComPkg.hs +24/−10
- templates/Cryptol.hs +18/−7
- templates/GHC.hs +17/−3
- templates/GaloisPkg.hs +24/−12
- templates/Greencard.hs +24/−12
- templates/HDirectLib.hs +14/−3
- templates/Haddock.hs +13/−4
- templates/Happy.hs +18/−8
- templates/HsDotnet.hs +175/−0
- templates/Hugs98.hs +12/−3
- templates/Hugs98Net.hs +16/−3
- templates/PubCryptol.hs +19/−9
- templates/SOE.hs +59/−42
- tests/Tests.hs +37/−0
- tools/Wrapper.hs +17/−0
- tools/custWrap.exe binary
- tools/msiIcon.c +1/−1
Bamse/Builder.hs view
@@ -9,13 +9,19 @@ -- Stability : provisional -- Portability : portable ----- Toplevel module for bamse library/app.--- --- ToDo:--- - ability to organise installed bits into features/sub parts.+-- Toplevel module for the @Bamse@ library/app. Use @genBuilder@+-- to do the generation of an MSI; it taking a specification of the+-- installer you are wanting to create. That along with the command-line+-- settings are then used to kick off the creation of an MSI database,+-- which will incorporate not only the metadata (installer name, shortcuts etc.)+-- but also the file content and structure that makes up the tree of+-- files you want to install on the user's machine. -- ---------------------------------------------------------------------module Bamse.Builder ( genBuilder ) where+module Bamse.Builder + ( genBuilder + , genBuilderArgs+ ) where import Bamse.Package import Bamse.Writer@@ -26,36 +32,51 @@ import Bamse.DialogUtils import System.Win32.Com ( coRun )-import IO-import Util.Path ( dirname, appendSep, toPlatformPath, joinPath, splitPath, appendPath )-import Util.Dir-import Util.List ( ifCons )+import System.FilePath+import Bamse.Util.Dir+import Bamse.Util.List ( ifCons ) -import System -import IO-import Monad ( when )-import Maybe+import System.Cmd+import System.IO+import Data.Maybe import Bamse.Options import System.Directory +-- ToDo:+-- - ability to organise installed bits into features/sub parts.+-- ++-- | @genBuilderArgs pkg argv@ constructs an MSI from the given package+-- description + a set of command-line of arguments @args@.+genBuilderArgs :: PackageData -> [String] -> IO ()+genBuilderArgs pkg args = do+ opts <- getOptionsFrom args (p_defOutFile pkg)+ genBuilderOpts pkg opts++-- | @genBuilder pkg @ constructs an MSI from the given package+-- description, plus taking the command-line arguments from @getArgs@. genBuilder :: PackageData -> IO () genBuilder pkg = do putStrLn ("Installer builder for: " ++ name (p_pkgInfo pkg)) >> hFlush stdout opts <- getOptions (p_defOutFile pkg)+ genBuilderOpts pkg opts++genBuilderOpts :: PackageData -> Options -> IO ()+genBuilderOpts pkg opts = do ds <- (p_fileMap pkg) (opt_ienv opts)- (dsDist, ienv) <- mkDistTree (opt_ienv opts) (srcDir $ opt_ienv opts)- (name $ p_pkgInfo pkg) (p_distFileMap pkg)- ds+ (dsDist, _ienv) <- mkDistTree (opt_ienv opts) + (normalise $ dropTrailingPathSeparator $ srcDir $ opt_ienv opts)+ (name $ p_pkgInfo pkg)+ (p_distFileMap pkg)+ ds let pkg' = pkg{ p_files = dsDist , p_dialogs = - (if p_userInstall pkg- then (setupTypeDialog:)- else if isJust (p_ghcPackage pkg)- then (ghcPkgDialog:)- else id) $+ ifCons (p_userInstall pkg) setupTypeDialog $+ ifCons (isJust (p_cabalPackage pkg)) (cabalDialog (fromJust (p_cabalPackage pkg))) $+--retired: ifCons (isJust (p_ghcPackage pkg)) ghcPkgDialog $ -- add customization selection dialog only if the -- builder supplies the relevant features.- case options (opt_ienv opts) of+ case options_ (opt_ienv opts) of [] -> [] os -> [customizeDialog os] , p_productGUID = fromJust (opt_productGUID opts)@@ -66,18 +87,18 @@ let bamseDir = toolDir (p_ienv pkg') coRun $ do (_, ts, tabs, reps) <- doInstall [] (genTables pkg')- let env = + let wenv = WriterEnv { w_toolDir = bamseDir , w_templateDir = lFile (lFile bamseDir "data") "msi" , w_outFile = outFile (p_ienv pkg')- , w_srcDir = dirname (srcDir $ p_ienv pkg')+ , w_srcDir = normalise (takeDirectory (srcDir $ p_ienv pkg')) , w_package = pkg' }- outputMSI env tabs ts reps+ outputMSI wenv tabs ts reps return () where- options ienv+ options_ ienv = ifCons (not (null (p_extensions pkg ienv))) ("Register file extensions", "OptFileExt", True) $ ifCons (not (null (p_desktopShortcuts pkg ienv)))@@ -101,16 +122,16 @@ let outDir = appendP fp (appendP "out" nm) catch (createDirectory outDir) (\ _ -> return ()) copyOver outDir ds- ds <- allFiles outDir- return (ds, ienv{srcDir=outDir})+ ds1 <- allFiles outDir+ return (ds1, ienv{srcDir=outDir}) where copyOver _ Empty = return () copyOver outDir (File f) = do case fn f of- Nothing -> return ()- Just f -> do- let cmd = ("copy /b \"" ++ f ++ "\" \"" ++ - appendP outDir (dropDirPrefix topDir f) ++ "\" > nul")+ Nothing -> return ()+ Just fnm -> do+ let cmd = ("copy /b \"" ++ fnm ++ "\" \"" ++ + appendP outDir (dropDirPrefix topDir fnm) ++ "\" > nul") system cmd return () copyOver outDir (Directory fp subs) = do@@ -119,4 +140,4 @@ (fn fp) mapM_ (copyOver outDir) subs - appendP a b = toPlatformPath $ appendPath a b+ appendP a b = normalise (a </> b)
Bamse/DiaWriter.hs view
@@ -14,7 +14,7 @@ -------------------------------------------------------------------- module Bamse.DiaWriter where -import Bamse.Dialog+--import Bamse.Dialog import Bamse.MSITable import Bamse.IMonad import Bamse.Package@@ -24,11 +24,11 @@ import Data.Bits import Data.Maybe -writeDialog :: PackageData -> Maybe GhcPackage -> Bool -> Dialog -> IM ()-writeDialog pkg ghcPackage hasLicense+writeDialog :: PackageData -> Bool -> Dialog -> IM ()+writeDialog pkg hasLicense (Dialog diaName cs conds evs (hc,vc) (w,h) attrs- title first def cancel+ ttle first def cancel afterDlg afterDlgCond props) = do addRow (newDialog [ "Dialog" -=> Just (string diaName) , "HCentering" -=> Just (int hc)@@ -36,7 +36,7 @@ , "Width" -=> Just (int w) , "Height" -=> Just (int h) , "Attributes" -=> Just (int (flattenAttrib attrs))- , "Title" -=> Just (string title)+ , "Title" -=> Just (string ttle) , "Control_First" -=> Just (string first) , "Control_Default" -=> Just (string def) , "Control_Cancel" -=> Just (string cancel)@@ -52,8 +52,11 @@ | otherwise -> (afterDlg, afterDlgCond) "SetupKindDialog" | hasLicense -> ("LicenseAgreementDlg", "IAgree = \"Yes\" AND ShowLicenseDlg = 1")+ | isJust (p_cabalPackage pkg) ->+ ("CabalDialog", afterDlgCond) | otherwise -> (afterDlg, afterDlgCond) "CustomizeDlg" -> (afterDlg, afterDlgCond)+ _ -> (afterDlg, afterDlgCond) addRow (newControlEvent [ "Dialog_" -=> Just (string afterDlg') -- "WelcomeDlg") , "Control_" -=> Just (string "Next")@@ -73,7 +76,10 @@ -- used to follow (ditto for its Back button.) let nextDlg = case afterDlg of- "WelcomeDlg" -> "SetupTypeDlg"+ "WelcomeDlg" -> + if diaName == "SetupKindDialog" && isJust (p_cabalPackage pkg)+ then "CabalDialog"+ else "SetupTypeDlg" "SetupKindDialog" -> "SetupTypeDlg" "CustomizeDlg" -> "VerifyReadyDlg" _ -> error ("unknown/unsupported dialog: " ++ afterDlg)@@ -83,7 +89,7 @@ , "Argument" -=> Just (string nextDlg) , "Condition" -=> Just (string "1") -- "NOT Installed" ]))- ioToIM (print (nextDlg,diaName))+-- ioToIM (print (nextDlg,diaName)) addRow (newControlEvent [ "Dialog_" -=> Just (string nextDlg) -- "SetupTypeDlg" , "Control_" -=> Just (string "Back") , "Event" -=> Just (string "NewDialog")@@ -99,22 +105,11 @@ setupGhcPackage :: GhcPackage -> IM () setupGhcPackage pkg = do let pkg_file = fromMaybe "package.pkg" (ghc_packageFile pkg)- addRow (newCustomAction- [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")- -- ignore errors- , "Type" -=> Just (int (50+64))- , "Source" -=> Just (string "GHCPKGDIR")- , "Target" -=> Just (string ("-r " ++ ghc_packageName pkg))- ])- mapM_ (\ act -> + mapM_ (\ act -> do addRow (act [ "Action" -=> Just (string "INSTALLGHCPKG") , "Condition" -=> Just (string ("NOT Installed AND RUNPKGMGR=1")) , "Sequence" -=> Just (int 6601)- ]))- [ newAdminExecuteSequence- , newInstallExecuteSequence- ]- mapM_ (\ act -> + ]) addRow (act [ "Action" -=> Just (string "UNINSTALL_GHC_PKG") , "Condition" -=> Just (string "REMOVE") , "Sequence" -=> Just (int 6602)@@ -122,6 +117,13 @@ [ newAdminExecuteSequence , newInstallExecuteSequence ]+ addRow (newCustomAction+ [ "Action" -=> Just (string "UNINSTALL_GHC_PKG")+ -- ignore errors+ , "Type" -=> Just (int (50+64))+ , "Source" -=> Just (string "GHCPKGDIR")+ , "Target" -=> Just (string ("-r " ++ ghc_packageName pkg))+ ]) let opts = "-DTARGETDIR=\"[TARGETDIR]\\\"" ++ case ghc_pkgCmdLine pkg of@@ -134,17 +136,95 @@ , "Target" -=> Just (string ("-u -i \"[TARGETDIR]"++pkg_file++"\" " ++ opts)) ]) -addControl diaName (Control name ty pName +setupCabalPackage :: CabalPackage -> IM ()+setupCabalPackage pkg = do+ mapM_ (\ act -> do+ addRow (act [ "Action" -=> Just (string "CONFIGCABAL")+ , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1"))+ , "Sequence" -=> Just (int 6601)+ ])+ addRow (act [ "Action" -=> Just (string "BUILDCABAL")+ , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1"))+ , "Sequence" -=> Just (int 6602)+ ])+ addRow (act [ "Action" -=> Just (string "INSTALLCABAL")+ , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL<>1 AND RUNPKGMGR=1"))+ , "Sequence" -=> Just (int 6603)+ ])+ addRow (act [ "Action" -=> Just (string "INSTALLCABAL2")+ , "Condition" -=> Just (string ("NOT Installed AND BUILDCABAL=1 AND RUNPKGMGR=1"))+ , "Sequence" -=> Just (int 6603)+ ])+ addRow (act [ "Action" -=> Just (string "UNINSTALL_CABAL")+ , "Condition" -=> Just (string "REMOVE")+ , "Sequence" -=> Just (int 6604)+ ]))+ [ newAdminExecuteSequence+ , newInstallExecuteSequence+ ]+ let opts = ""+{-+ "-DTARGETDIR=\"[TARGETDIR]\\\"" +++ case cabal_pkgCmdLine pkg of+ Nothing -> []+ Just v -> ' ':v+-}+ {-+ Performing Cabal operations:+ * unable to invoke 'runghc' directly here (via a Type:50 custom action), as+ we have to be in the target directory to perform the operation.+ * provide a simple call wrapper instead that simply adjusts the CWD before + invoking 'runghc'. It needs to be named "custWrap.exe" and present in the+ toplevel target directory. The source for it is in Wrapper.hs in the toplevel+ of the Bamse tree.+ -}+ fKey <- findExeFile "custWrap.exe"+ addRow (newCustomAction+ [ "Action" -=> Just (string "INSTALLCABAL")+ , "Type" -=> Just (int 18)+ , "Source" -=> Just (string fKey) -- "GHCPKG")+ , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install " ++ opts))+ ])+ addRow (newCustomAction+ [ "Action" -=> Just (string "INSTALLCABAL2")+ , "Type" -=> Just (int 18)+ , "Source" -=> Just (string fKey) -- "GHCPKG")+ , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup install --builddir=ldist" ++ opts))+ ])+ addRow (newCustomAction+ [ "Action" -=> Just (string "CONFIGCABAL")+ , "Type" -=> Just (int 18)+ , "Source" -=> Just (string fKey)+ , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup configure --builddir=ldist" ++ opts))+ ])+ addRow (newCustomAction+ [ "Action" -=> Just (string "BUILDCABAL")+ , "Type" -=> Just (int 18)+ , "Source" -=> Just (string fKey) -- "GHCPKG")+ , "Target" -=> Just (string ("[TARGETDIR] [GHCPKG] Setup build --builddir=ldist"))+ ])+ -- ToDo: fix+ addRow (newCustomAction+ [ "Action" -=> Just (string "UNINSTALL_CABAL")+ -- ignore errors+ , "Type" -=> Just (int (50+64))+ , "Source" -=> Just (string "GHCPKG")+ , "Target" -=> Just (string ("unregister " ++ cabal_packageName pkg))+ ])+++addControl :: String -> Control -> IM ()+addControl diaName (Control cname ty pName (x,y) (w,h) text as next help) = do addRow (newControl [ "Dialog_" -=> Just (string diaName)- , "Control" -=> Just (string name)+ , "Control" -=> Just (string cname) , "Type" -=> Just (string $ toControlTypeString ty) , "X" -=> Just (int x) , "Y" -=> Just (int y) , "Width" -=> Just (int width) , "Height" -=> Just (int height)- , "Attributes" -=> Just (int $ flattenAttrib as)+ , "Attributes" -=> Just (int $ flattenAttr as) , "Property" -=> fmap string pName , "Text" -=> mbString text , "Control_Next" -=> mbString next@@ -158,7 +238,7 @@ _ -> return () where- flattenAttrib as = fromIntegral (foldr marshal (0::Int32) as)+ flattenAttr ats = fromIntegral (foldr marshal (0::Int32) ats) addCheckBox onYes = do addRow (newCheckBox [ "Property" -=> fmap string pName@@ -183,8 +263,8 @@ , "Text" -=> Just (string txt) ]) - marshal x acc = acc .|.- case x of+ marshal mx acc = acc .|.+ case mx of Visible -> 0x01 Enabled -> 0x02 Sunken -> 0x04@@ -228,7 +308,7 @@ IconSize48 -> 0x00600000 -- radio button group attributes HasBorder -> 0x01000000- _ -> 0x0+-- _ -> 0x0 {- BillboardName String@@ -240,8 +320,8 @@ TimeRemaining Int -} - toControlTypeString x = - case x of+ toControlTypeString tx = + case tx of PushButton{} -> "PushButton" PathEdit -> "PathEdit" Line{} -> "Line"@@ -250,12 +330,13 @@ Bitmap{} -> "Bitmap" RadioButtonGroup{} -> "RadioButtonGroup" CheckBox{} -> "CheckBox"- _ -> error ("toControlTypeString: unhandled control ")+ _ -> error ("toControlTypeString: unhandled control") mbString :: String -> Maybe ColumnValue mbString "" = Nothing mbString x = Just (string x) +addControlEvent :: String -> (String, ControlEvent, String, String) -> IM () addControlEvent diaName (control, ev, cond, ordering) = addRow (newControlEvent [ "Dialog_" -=> Just (string diaName) , "Control_" -=> Just (string control)@@ -265,6 +346,7 @@ , "Ordering" -=> mbString ordering ]) +addControlCondition :: String -> (String, String, String) -> IM () addControlCondition diaName (cName, action, cond) = addRow (newControlCondition [ "Dialog_" -=> Just (string diaName) , "Control_" -=> Just (string cName)@@ -312,8 +394,8 @@ ValidateProductID -> "ValidateProductID" toEventArg :: ControlEvent -> Maybe ColumnValue-toEventArg x =- case x of+toEventArg ce =+ case ce of SetProperty _ "" -> Just (string "{}") SetProperty _ x -> Just (string x) AddLocal f -> Just (string f)
Bamse/DialogUtils.hs view
@@ -14,18 +14,19 @@ -------------------------------------------------------------------- module Bamse.DialogUtils ( ghcPkgDialog -- :: Dialog+ , cabalDialog -- :: Dialog , setupTypeDialog -- :: Dialog , customizeDialog -- :: Dialog ) where ---import Bamse.Package+import Bamse.GhcPackage import Bamse.Dialog ghcPkgDialog :: Dialog ghcPkgDialog = addControl (Control "Msg" (Text "foo") Nothing (40,180) (180,40)- "WARNING: unable to locate ghc-pkg; automatic installation not available"+ "WARNING: unable to locate 'ghc-pkg'; automatic installation not available" [Transparent,Enabled] "" "") $ addCond ("Msg", "Show", "GHCPKGDIR=\"\"") $@@ -37,11 +38,39 @@ [ ("Yes", "1") , ("No", "0") ]- "RUNPKGMGR"+ ("InstallKind","RUNPKGMGR")+ Nothing "WelcomeDlg" "NOT Installed"- ("InstallKind", "2")+ [("InstallKind", "2")] +cabalDialog :: CabalPackage -> Dialog+cabalDialog pkg = + addControl (Control "Msg" (Text "foo") Nothing+ (40,180) (180,40)+ "WARNING: unable to locate 'runghc'; automatic installation not available"+ [Transparent,Enabled]+ "" "") $+ addCond ("Msg", "Show", "GHCPKG=\"\"") $+ addCond ("RegKind", "Disable", "GHCPKG=\"\"") $+ (if (cabal_fromSource pkg) + then addCond ("BuildKind", "Disable", "GHCPKG=\"\"") + else id) $+ mkChoiceDialog "CabalDialog"+ "Cabal package installation"+ "{\\VerdanaBold13}Select Cabal package installation type"+ "The installer can automatically register the package; do you want to?"+ yesNos+ ("RegKind","RUNPKGMGR")+ (if (cabal_fromSource pkg)+ then (Just (yesNos,"Do you also want to configure and build from source?" ,("BuildKind","BUILDCABAL")))+ else Nothing)+ "WelcomeDlg"+ "NOT Installed"+ (("RegKind", "2") :(if cabal_fromSource pkg then [("BuildKind", "2")] else []))+ where+ yesNos= [ ("Yes", "1"), ("No", "0") ]+ setupTypeDialog :: Dialog setupTypeDialog = -- Hack: ALLUSERS needs to be undefined in order@@ -59,10 +88,11 @@ [ ("Just for me", "0") , ("Everyone", "2") ]- "InstallKind"+ ("InstallKind","InstallKind")+ Nothing "WelcomeDlg" "NOT Installed"- ("InstallKind", "2")+ [("InstallKind", "2")] -- dialog for letting the user control the level of shell integration -- to use (file extensions, start menu, desktop shortcuts.)@@ -142,14 +172,15 @@ -> String -- title -> String -- description -> [(String, String)]- -> PropertyName+ -> (String, PropertyName)+ -> Maybe ([(String, String)], String, (String,PropertyName)) -> DialogName -> String- -> (PropertyName, String)+ -> [(PropertyName, String)] -> Dialog mkChoiceDialog diaNm diaHeader diaTitle diaDesc opts - propName afterDiag afterDiagCond- (initProp, initVal)+ (ctrlName,propName) mbSnd afterDiag afterDiagCond+ initVals = Dialog { dia_name = diaNm , dia_ctrls = controls , dia_conds = conditions@@ -163,7 +194,7 @@ , dia_cancel = "cancelButton" , dia_after = afterDiag , dia_cond = afterDiagCond- , dia_props = [(initProp, initVal)]+ , dia_props = initVals } where controls@@ -182,16 +213,34 @@ (0,0) (370,234) "[DialogBitmap]" [Visible] "Back" ""- , Control "InstallKind"+ , Control ctrlName (RadioButtonGroup (map (\(txt,val) -> RadioButton txt val) opts)) (Just propName)- (130,120) (180,40) ""+ (130,95) (radioTextWidth opts,40) "" [{-Transparent,-}Enabled,Visible] "" ""- ]+ ] +++ case mbSnd of+ Nothing -> []+ Just (opts2,dd,(cName,bPropName)) ->+ [ Control ("Description_"++cName) (Text "foo") Nothing+ (125,140) (220,60)+ dd+ [Transparent, NoPrefix, Enabled, Visible]+ "" ""+ , Control cName+ (RadioButtonGroup (map (\(txt,val) -> RadioButton txt val) opts2))+ (Just bPropName)+ (130,160) (radioTextWidth opts,40) ""+ [{-Transparent,-}Enabled,Visible]+ "" "" ]+ conditions = [] events = [ ("cancelButton", EndDialog "Exit", "1", "1") ]++ radioTextWidth ls = 10 + 10*maximum (map (length.fst) ls)+ addEvent :: CEvent -> Dialog -> Dialog addEvent ev d = d{dia_events=ev:dia_events d}
Bamse/GhcPackage.hs view
@@ -9,7 +9,8 @@ -- Stability : provisional -- Portability : portable ----- Specifying the contents of a GHC package.+-- Specifying the contents of a GHC package...uh, more Cabal nowadays :-)+-- (the GHC package support has effectively been disabled\/retired.) -- -------------------------------------------------------------------- module Bamse.GhcPackage where@@ -22,7 +23,21 @@ , ghc_packageFile :: Maybe FilePath -- ^ Dist-tree local path to .pkg file , ghc_pkgCmdLine :: Maybe String- -- ^ Extra command-line options to feed 'ghc-pkg' when _installing_.+ -- ^ Extra command-line options to feed @ghc-pkg@ when /installing/. -- more to follow.. -- , ghc_stuff :: String+ } ++data CabalPackage+ = CabalPackage + { cabal_packageName :: String + -- ^ Name of the package; this must match the one in the .pkg file.+ , cabal_forGhcVersion :: String+ -- ^ What version of GHC to install the package for.+ , cabal_packageFile :: Maybe FilePath+ -- ^ Dist-tree local path to .pkg file+ , cabal_pkgCmdLine :: Maybe [(String, String)]+ -- ^ Extra command-line options to feed @ghc-pkg@ when performing a particular verb.+ , cabal_fromSource :: Bool+ -- ^ Set to @True@ if you want to support from-source building }
Bamse/IMonad.hs view
@@ -31,6 +31,8 @@ , addFile , replaceFile , getFiles+ + , findExeFile , Id ) where@@ -40,6 +42,8 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import Data.List +import System.FilePath+ type Id = String data IState @@ -139,6 +143,7 @@ newId = IM $ \ st -> case istate_guids st of (g:gs) -> return (show g, st{istate_guids=gs})+ [] -> error "the GUID Store ran out of uniques; how weird." -- an infinite supply of GUIDs. new_guids :: IO [GUID]@@ -147,3 +152,11 @@ xs <- unsafeInterleaveIO new_guids return (x : xs) +findExeFile :: String -> IM String+findExeFile t = do+ ls <- getFiles + let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (System.FilePath.takeFileName x, st)) ls+ case lookup t ls' of+ Nothing -> do+ ioToIM (fail ("ERROR: findExeFile, unable to locate target file: " ++ show t))+ Just (_,(fKey,_,_,_)) -> return fKey
Bamse/MSIExtra.hs view
@@ -17,8 +17,8 @@ module Bamse.MSIExtra where import Data.Char ( toUpper )-import Util.Path ( fileSuffix ) import Bamse.Package+import System.FilePath ( takeExtension ) -- product ID tags (from MsiDefs.h, not provided in the TLB). data ProductIDTag@@ -53,7 +53,7 @@ where badChars = " +,;=[]" restricted_nm = map (\ ch -> if ch `elem` badChars then '_' else ch) nm- ext = fileSuffix nm+ ext = case System.FilePath.takeExtension nm of { '.':xs -> xs ; xs -> xs } short_form | length restricted_nm > 8 || length ext > 3 = take 6 (map toUpper restricted_nm) ++ "~1|" ++ nm | otherwise = restricted_nm
Bamse/MSITable.hs view
@@ -134,7 +134,7 @@ ) where -import Util.List+import Bamse.Util.List import Data.Maybe import Bamse.PackageUtils ( expandString ) @@ -155,6 +155,7 @@ ) type ColumnName = String +-- | 'ColumnType' type ColumnType = ( Bool -- True => NOT NULL. , Bool -- True => is primary key.
Bamse/Options.hs view
@@ -17,15 +17,18 @@ import Bamse.Package import Bamse.Writer ( getProductCodes ) -import System-import Util.GetOpts+import System.Environment+import System.Exit+import Bamse.Util.GetOpts -- for validateOptions / getOptions:-import System.Win32.Com ( newGUID, guidToString )-import System.IO ( hPutStrLn, stderr, stdout )-import Data.Maybe ( isNothing, fromJust )-import Control.Monad ( when )-import Util.Path+import System.Win32.Com ( newGUID, guidToString )+import System.IO ( hPutStrLn, stderr, stdout )+import System.Directory ( getCurrentDirectory )+import Data.Maybe ( isNothing, fromJust, isJust )+import Control.Monad ( when, foldM )+import System.FilePath+--import Util.Path import System.Win32.Com.Base ( getModuleFileName ) import Foreign.Ptr ( nullPtr ) import Bamse.PackageUtils ( addEnvVar )@@ -74,6 +77,7 @@ , opt_defines = [] } +versionStr :: String versionStr = "<installer>" help :: String -> String@@ -121,114 +125,128 @@ toGUID xs@('{':_) = xs -- '}' toGUID ls = '{':ls ++ "}" +helpError :: IO a helpError = do showHelp exitWith (ExitFailure 1) +showHelp :: IO () showHelp = do p <- getProgName hPutStrLn stderr (help p) validateOptions :: FilePath -> Options -> [FilePath] -> IO Options-validateOptions defOut opts inps = do+validateOptions defOut opts0 inps = do+ foldM (\ o f -> f o) + opts0+ [ topInstallTree+ , outputReqd+ , productGUIDReqd+ , revisionGUIDReqd+ , dataDirReqd+ ]+ where -- the top of the install tree must be given.- opts <-- if not (opt_showInfo opts) && isNothing (opt_srcDir opts) && length inps /= 1- then helpError- else if isNothing (opt_srcDir opts)- then return opts{opt_srcDir=Just (head inps)}- else return opts+ topInstallTree opts + | not (opt_showInfo opts) && isNothing (opt_srcDir opts) && length inps /= 1 = helpError+ | isNothing (opt_srcDir opts) = return opts{opt_srcDir=Just (head inps)}+ | otherwise = return opts+ -- if in update mode, an output file is reqd.- opts <- - if opt_update opts- then if isNothing (opt_outFile opts)- then do- let opts' = opts{opt_outFile=Just defOut}- hPutStrLn stderr ("WARNING: no output file given, using: " ++ fromJust (opt_outFile opts'))- return opts'- else- return opts- else return opts+ outputReqd opts + | not (opt_update opts) || isJust (opt_outFile opts) = return opts+ | otherwise = do+ let opts' = opts{opt_outFile=Just defOut}+ hPutStrLn stderr ("WARNING: no output file given, using: " ++ fromJust (opt_outFile opts'))+ return opts'+ -- if not in update mode, better give the GUIDs- opts <-- if not (opt_update opts) && not (opt_showInfo opts)- then if isNothing (opt_productGUID opts) && not (opt_genGUIDs opts)- then do- hPutStrLn stderr ("ERROR: missing product GUID option")- helpError- else if opt_genGUIDs opts- then do- g <- newGUID- let n = guidToString g- n `seq` return opts{opt_productGUID=Just n}- else- return opts- else return opts- opts <-- if not (opt_update opts) && not (opt_showInfo opts)- then if isNothing (opt_revisionGUID opts) && not (opt_genGUIDs opts)- then do- hPutStrLn stderr ("ERROR: missing revision GUID option")- helpError- else if opt_genGUIDs opts- then do- g <- newGUID- let n = guidToString g- n `seq` return opts{opt_revisionGUID=Just n}- else- return opts- else return opts- opts <- - if isNothing (opt_dataDir opts)- then do+ productGUIDReqd opts + | opt_update opts || opt_showInfo opts = return opts+ | opt_genGUIDs opts = do+ g <- newGUID+ let n = guidToString g+ n `seq` return opts{opt_productGUID=Just n}+ | isNothing (opt_productGUID opts) = do+ hPutStrLn stderr ("ERROR: missing product GUID option")+ helpError+ | otherwise = return opts++ revisionGUIDReqd opts+ | (opt_update opts) || (opt_showInfo opts) = return opts+ | opt_genGUIDs opts = do+ g <- newGUID+ let n = guidToString g+ n `seq` return opts{opt_revisionGUID=Just n}+ | isNothing (opt_revisionGUID opts) = do+ hPutStrLn stderr ("ERROR: missing revision GUID option")+ helpError+ | otherwise = return opts++ dataDirReqd opts+ | isJust (opt_dataDir opts) = return opts+ | otherwise = do let opts' = opts{opt_dataDir=opt_toolDir opts} hPutStrLn stderr ("WARNING: no data-dir given, setting it equal to tool-dir") return opts'- else return opts- return opts getOptions :: FilePath -> IO Options getOptions defOut = do ls <- getArgs- (opts, inps) <- parseArgs ls- opts <- validateOptions defOut opts inps- opts <-- if opt_update opts || opt_showInfo opts- then do { (a,b) <- getProductCodes (fromJust (opt_outFile opts)) ;- return opts{ opt_productGUID = Just a- , opt_revisionGUID = Just b- } }- else return opts- when (opt_help opts) (showHelp >> exitWith ExitSuccess)- when (opt_version opts) (hPutStrLn stderr versionStr >> exitWith ExitSuccess)- when (opt_showInfo opts) $ do- hPutStrLn stdout $ "Product code: " ++ fromJust (opt_productGUID opts)- hPutStrLn stdout $ "Revision code: " ++ fromJust (opt_revisionGUID opts)+ getOptionsFrom ls defOut++getOptionsFrom :: [String] -> FilePath -> IO Options+getOptionsFrom args defOut = do+ (opts0, inps) <- parseArgs args+ opts1 <- validateOptions defOut opts0 inps+ opts2 <-+ if not (opt_update opts1) && not (opt_showInfo opts1)+ then return opts1+ else do+ (a,b) <- getProductCodes (fromJust (opt_outFile opts1)) ;+ return opts1{ opt_productGUID = Just a+ , opt_revisionGUID = Just b+ }++ when (opt_help opts2) (showHelp >> exitWith ExitSuccess)+ when (opt_version opts2) (hPutStrLn stderr versionStr >> exitWith ExitSuccess)+ when (opt_showInfo opts2) $ do+ hPutStrLn stdout $ "Product code: " ++ fromJust (opt_productGUID opts2)+ hPutStrLn stdout $ "Revision code: " ++ fromJust (opt_revisionGUID opts2) exitWith ExitSuccess- mapM_ processDefine (opt_defines opts)+ os <- mapM processDefine (opt_defines opts2)+ cwd <- getCurrentDirectory let- srcDir = - case opt_srcDir opts of+ sourceDir = + case opt_srcDir opts2 of Nothing -> error "no srcDir"- Just x -> toPlatformPath (joinPath $ splitPath x)+ Just x + | isAbsolute x -> normalise (dropTrailingPathSeparator x)+ | otherwise -> normalise $+ case normalise (dropTrailingPathSeparator x) of+ "." -> cwd+ "" -> cwd+ y -> cwd </> y oFile = - case opt_outFile opts of- Nothing -> toPlatformPath defOut- Just x -> toPlatformPath x+ case opt_outFile opts2 of+ Nothing -> normalise defOut+ Just x -> normalise x bfile <- getModuleFileName nullPtr- let bdir = toPlatformPath $ appendSep (dirname bfile)+ let bdir = normalise (addTrailingPathSeparator (takeDirectory bfile)) let ienv = InstallEnv- { toolDir = bdir- , srcDir = srcDir- , distDir = error "distDir not filled in yet"- , outFile = oFile+ { toolDir = maybe bdir id (opt_toolDir opts2)+ , srcDir = sourceDir+ , distDir = error "distDir not filled in yet"+ , outFile = oFile+ , userOpts = os }- return opts{opt_ienv=ienv}+ return opts2{opt_ienv=ienv} -processDefine :: String -> IO ()+processDefine :: String -> IO (String,String) processDefine str = case break (=='=') str of- (as,[]) -> addEnvVar as ""- (as,_:bs) -> addEnvVar as bs+ (as,[]) -> addEnvVar as "" >> return (as,"")+ (as,_:bs) -> addEnvVar as bs >> return (as,bs)+
Bamse/Package.hs view
@@ -18,14 +18,15 @@ ( module Bamse.Package , module Bamse.GhcPackage , module Bamse.Dialog+ , module Bamse.Util.Dir ) where -import Util.Dir ( DirTree )+import Bamse.Util.Dir import Bamse.Dialog import Bamse.GhcPackage -- --- The functions provided by a template are parameterised over+-- | The functions provided by a template are parameterised over -- the context the installer eventually runs in. Apart from -- having access to the toplevel directory of the distribution/install -- tree, these functions also have access to the directory of@@ -35,11 +36,12 @@ -- data InstallEnv = InstallEnv - { toolDir :: FilePath -- where installer tool lives - , srcDir :: FilePath -- path to toplevel directory of files to be distributed.- , distDir :: FilePath -- user-supplied path to directory containing installer- -- template specific files.- , outFile :: FilePath -- file to output installer as.+ { toolDir :: FilePath -- where installer tool lives + , srcDir :: FilePath -- path to toplevel directory of files to be distributed.+ , distDir :: FilePath -- user-supplied path to directory containing installer+ -- template specific files.+ , outFile :: FilePath -- file to output installer as.+ , userOpts :: [(String,String)] -- invocation-time (name,value) pairs } deriving Show @@ -88,7 +90,9 @@ , p_productGUID :: String -- expected form: "{...}" , p_revisionGUID :: String -- ditto , p_nestedInstalls :: [(FilePath, Maybe String)]- , p_ghcPackage :: Maybe GhcPackage+-- , p_ghcPackage :: Maybe GhcPackage+ , p_cabalPackage :: Maybe CabalPackage+ , p_assemblies :: [Assembly] , p_ienv :: InstallEnv , p_verbose :: Bool }@@ -121,7 +125,9 @@ , p_services = fieldError "services" , p_productGUID = fieldError "productGUID" , p_revisionGUID = fieldError "revisionGUID"- , p_ghcPackage = fieldError "ghcPackage"+-- , p_ghcPackage = fieldError "ghcPackage"+ , p_cabalPackage = fieldError "cabalPackage"+ , p_assemblies = [] , p_nestedInstalls = fieldError "nestedInstalls" , p_ienv = fieldError "ienv" , p_verbose = fieldError "verbose"@@ -129,6 +135,45 @@ where fieldError f = error ("defPackageData.p_" ++ f ++ ": not filled in") +minimalPackageData :: PackageData+minimalPackageData = pkg+ where+ pkg =+ PackageData { p_files = fieldError "files"+ , p_fileMap = fieldError "fileMap"+ , p_distFileMap = Nothing+ , p_defOutFile = fieldError "defOutFile"+ , p_pkgInfo = fieldError "pkgInfo"+ , p_webSite = ""+ , p_bannerBitmap = \ _ienv -> Nothing+ , p_bgroundBitmap = \ _ienv -> Nothing+ , p_registry = []+ , p_baseFeature = fieldError "baseFeature"+ , p_features = []+ , p_featureMap = Nothing+ , p_startMenu = \ _ienv -> ("",[])+ , p_desktopShortcuts = \ _ienv -> []+ , p_extensions = \ _ienv -> []+ , p_verbs = []+ , p_license = \ _ienv -> Nothing+ , p_userRegistration = False+ , p_defaultInstallFolder = Nothing+ , p_userInstall = True+ , p_dialogs = []+ , p_finalMessage = Nothing+ , p_notForAll = False+ , p_services = []+ , p_productGUID = fieldError "productGUID"+ , p_revisionGUID = fieldError "revisionGUID"+ , p_cabalPackage = fieldError "cabalPackage"+ , p_assemblies = []+ , p_nestedInstalls = []+ , p_ienv = fieldError "ienv"+ , p_verbose = False+ }++ fieldError f = error ("minimalPackageData.p_" ++ f ++ ": not filled in")+ -- various supporting types that don't quite belong here.. data Shortcut = Shortcut@@ -199,3 +244,29 @@ = Leaf a | Node a [Tree a] ++-- | @Assembly@ defines a reference to a local DLL that you+-- want to be treated as an assembly (and installed/registered as such.)+data Assembly+ = Assembly+ { assem_dll :: FilePath+ , assem_manifest :: Maybe FilePath -- optional; preferably embedded in the assembly DLL as resource..+ , assem_privatePath :: Maybe FilePath -- if you don't want to install into GAC; untested..+ , assem_name :: String+ , assem_version :: String+ , assem_culture :: String+ , assem_publicKey :: String+ , assem_win32 :: Bool+ }++emptyAssembly :: Assembly+emptyAssembly = Assembly+ { assem_dll = ""+ , assem_manifest = Nothing+ , assem_privatePath = Nothing+ , assem_name = ""+ , assem_version = "0.0.0.0"+ , assem_culture = "" -- neutral+ , assem_publicKey = ""+ , assem_win32 = False -- MSIL in other words.+ }
Bamse/PackageGen.hs view
@@ -21,14 +21,16 @@ import Bamse.DiaWriter import Bamse.PackageUtils ( dropDirPrefix ) -import Util.Dir-import Util.Path-import Util.List+import Bamse.Util.Dir+--import Util.Path+import System.FilePath hiding ( addExtension )+import Bamse.Util.List import Data.Maybe ( isJust, isNothing, fromJust )+import Data.List ( inits ) import System.IO ( openFile, IOMode(..), hFileSize, hClose ) import Control.Monad ( when, zipWithM_ )-import Debug.Trace+--import Debug.Trace -- fileSize :: FilePath -> IO Integer@@ -47,6 +49,7 @@ makeShortcutsOptional addFileExtensions (fst $ p_baseFeature pkg_data) (p_extensions pkg_data ienv) addVerbs (p_verbs pkg_data)+ addAssemblies (p_baseFeature pkg_data) (p_assemblies pkg_data) configureLicense (p_license pkg_data ienv) setUserRegistration (p_userRegistration pkg_data) setCustomTargetDir (p_defaultInstallFolder pkg_data)@@ -59,18 +62,26 @@ setURL (p_webSite pkg_data) addBannerBitmap "packageBanner" (p_bannerBitmap pkg_data ienv) addDialogBitmap "bgBanner" (p_bgroundBitmap pkg_data ienv)- when (isJust (p_ghcPackage pkg_data))- (setupGhcPackage (fromJust (p_ghcPackage pkg_data)))- mapM_ (writeDialog pkg_data (p_ghcPackage pkg_data) (isJust $ p_license pkg_data ienv))+ mapM_ (writeDialog pkg_data (isJust $ p_license pkg_data ienv)) (p_dialogs pkg_data) addFiles addFeatures (p_baseFeature pkg_data) (p_featureMap pkg_data) (p_features pkg_data)- addRegSearch (p_ghcPackage pkg_data)+ addRegSearch (p_cabalPackage pkg_data) addServices (p_services pkg_data)+ maybe (return ())+ (\ cp -> do+ addDirOrFile pkg_data False (toolDir (p_ienv pkg_data) </> "tools" </> "custWrap.exe")+ setupCabalPackage cp)+ (p_cabalPackage pkg_data)+{-+ when (isJust (p_ghcPackage pkg_data))+ (setupGhcPackage (fromJust (p_ghcPackage pkg_data)))+-} addNestedInstalls (p_nestedInstalls pkg_data) where ienv = p_ienv pkg_data +addServices :: [Service] -> IM () addServices ls = case ls of [] -> return ()@@ -83,7 +94,7 @@ dirs <- getDirs comps <- getComponents let theBinary - | null (fileSuffix (serv_binary s)) = changeSuffix ".exe" (serv_binary s) + | null (takeExtension (serv_binary s)) = replaceExtension (serv_binary s) "exe" | otherwise = serv_binary s let cKey = findExeComponent dirs comps theBinary user_pwd = @@ -113,8 +124,7 @@ ])) -- All services that are installed will be removed during uninstall. -- Make it so.- v <- newId- let tKey = idToKey v + tKey <- newId >>= return.idToKey addRow (newServiceControl ([ "ServiceControl" -=> Just (string tKey) , "Name" -=> Just (string (serv_name s))@@ -123,35 +133,53 @@ ])) -- testing Registry searching..look for a GHC installation.+addRegSearch :: Maybe CabalPackage -> IM () addRegSearch ghcPackage | isNothing ghcPackage = return () | otherwise = do let pkg = fromJust ghcPackage- sId <- newId- let installDirKey = idToKey sId- sId <- newId- let ghcPkgDirKey = idToKey sId+ installDirKey <- newId >>= return.idToKey+ ghcPkgDirKey <- newId >>= return.idToKey+ gId <- newId+ let ghcPkgKey = idToKey gId+{-+ addRow (newSignature [ "Signature" -=> Just (string installDirKey)+ , "FileName" -=> Just (string "README.txt")+ ])+-}+ addRow (newSignature [ "Signature" -=> Just (string ghcPkgKey)+ , "FileName" -=> Just (string "runghc.exe")+ ])+{-+ addRow (newSignature [ "Signature" -=> Just (string ghcPkgDirKey)+ , "FileName" -=> Just (string "bin")+ ])+-}+ addRow (newAppSearch [ "Property" -=> Just (string "GHCPKG")+ , "Signature_" -=> Just (string ghcPkgKey)+ ]) addRow (newAppSearch [ "Property" -=> Just (string "GHCPKGDIR") , "Signature_" -=> Just (string ghcPkgDirKey) ])- addRow (newAppSearch [ "Property" -=> Just (string "GhcInstallDir")++ addRow (newAppSearch [ "Property" -=> Just (string "InstallDir") , "Signature_" -=> Just (string installDirKey) ]) addRow (newRegLocator [ "Signature_" -=> Just (string installDirKey)- , "Root" -=> Just (int 2) -- HKLM- , "Key" -=> Just (string ("Software\\Haskell\\GHC\\ghc-"++ ghc_forVersion pkg))+ , "Root" -=> Just (int 1) -- 1=HKCU; 2=HKLM+ , "Key" -=> Just (string ("Software\\Haskell\\GHC\\ghc-"++ cabal_forGhcVersion pkg)) , "Name" -=> Just (string "InstallDir")- , "Type" -=> Just (int 2) -- 'Key' is a key.+ , "Type" -=> Just (int 0) -- 'Key' is a directory. ]) addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgDirKey) , "Parent" -=> Just (string installDirKey)- , "Path" -=> Just (string "bin\\")- ])- addRow (newSignature [ "Signature" -=> Just (string ghcPkgDirKey)- , "FileName" -=> Just (string "ghc-pkg.exe")+ , "Path" -=> Just (string "bin")+ , "Depth" -=> Just (int 1) ])- addRow (newSignature [ "Signature" -=> Just (string installDirKey)- , "FileName" -=> Just (string "ghc-pkg.exe")+ addRow (newDrLocator [ "Signature_" -=> Just (string ghcPkgKey)+ , "Parent" -=> Just (string ghcPkgDirKey)+ , "Path" -=> Just (string "")+ , "Depth" -=> Just (int 0) ]) --@@ -163,9 +191,9 @@ mkFileTables :: PackageData -> DirTree -> IM () mkFileTables pkg dTree = case dTree of- Empty -> return ()- Util.Dir.File l -> addDirOrFile pkg False l- Directory dName subs -> addDirOrFile pkg True dName >> mapM_ (mkFileTables pkg) subs+ Empty -> return ()+ Bamse.Util.Dir.File l -> addDirOrFile pkg False l+ Directory dName subs -> addDirOrFile pkg True dName >> mapM_ (mkFileTables pkg) subs -- -- Function: addDirOrFile@@ -193,12 +221,12 @@ -- files.) -- addDirOrFile :: PackageData -> Bool -> FilePath -> IM ()-addDirOrFile pkg isDir fPath = do+addDirOrFile pkg isDir fPath0 = do -- The 'controlling' directory of the file/dir. -- For a file, the parent dir; for a directory, itself. let dName- | isDir = fPath- | otherwise = dirname fPath+ | isDir = normalise (dropTrailingPathSeparator fPath)+ | otherwise = normalise (takeDirectory fPath) dirs <- getDirs let mbDir = lookupDirectory dName dirs fileKey <- @@ -220,19 +248,25 @@ -- first off, create the ancestors. let sDir = srcDir (p_ienv pkg)- let dNameRel = dropDirPrefix (dirname sDir) dName+ let dNameRel = dropDirPrefix (takeDirectory sDir) dName createDirPath (p_verbose pkg) "TARGETDIR" (splitPath2 dNameRel) let parentDir ds = case lookupDirectory dNameRel ds of Just x -> x _ -> "TARGETDIR"- dirs <- getDirs- let dirKey = parentDir dirs- when (null (shortLong (baseName dName))) - (ioToIM (putStrLn ("empty: "++ show (dName, baseName dName))))- if isSpecialFile + dirKey <- getDirs >>= return.parentDir+ when (null (shortLong (takeFileName dName))) + (ioToIM (putStrLn ("empty: "++ show (dName, takeFileName dName))))+ if not isSpecialFile then do+ comps <- getComponents+ case mbFindDirComponent dirKey comps of+ Just x -> return x+ Nothing -> do+ ioToIM (putStrLn ("INTERNAL ERROR: Component missing directory mapping: "++show (dName,sDir,dNameRel,dirKey)))+ return "TARGETDIR"+ else do compKey <- fmap idToKey newId compGUID <- newId dirKeyN <- newId@@ -252,23 +286,25 @@ , "KeyPath" -=> Just (string (if not isDir then fileKey else "")) ]) return compKey- else do- comps <- getComponents- return (findDirComponent dirKey comps)+ -- ..and finally, add file to the File table, associating the (possibly new) -- component key with it. when (not isDir) (do -- need to store the file size in the table; look it up. fsz <- ioToIM $ fileSize fPath when (p_verbose pkg) (ioToIM (putStrLn $ "Including: " ++ fPath))- addFile fPath fileKey compKey (shortLong (baseName fPath)) (show fsz))+ addFile fPath fileKey compKey (shortLong (takeFileName fPath)) (show fsz)) where+ fPath = normalise fPath0 isSpecialFile = isCompWorthy fPath -- Files with certain file extensions get put into sep. components. -- See 'addDirOrFile' comments as to why this is done.- isCompWorthy fpath = fileSuffix fpath `elem` ["exe", "dll", "ocx", "hlp"]+ isCompWorthy fpath = takeExtension fpath `elem` [".exe", ".dll", ".ocx", ".hlp"] +splitPath2 :: FilePath -> [FilePath]+splitPath2 xs = map joinPath $ tail $ inits $ splitDirectories xs+ -- Go down a directory path, adding components for directories -- that haven't been seen before. createDirPath :: Bool -> String -> [String] -> IM ()@@ -297,7 +333,7 @@ [ "Directory" -=> Just (string dirKey) , "Directory_Parent" -=> Just (string parentDirKey) , "DefaultDir" -=> - Just (string ((if parent == "TARGETDIR" then (".:"++) else id) (shortLong (baseName d))))+ Just (string ((if parent == "TARGETDIR" then (".:"++) else id) (shortLong (takeFileName d)))) ]) addRow (newComponent [ "Component" -=> Just (string compKey)@@ -348,7 +384,10 @@ -> Maybe (FilePath -> FeatureName) -> [Tree Feature] -> IM ()-addFeatures bFeat featMap fs = do+addFeatures bFeat featMap fs0 = do+ let fs + | null fs0 = [Leaf bFeat]+ | otherwise = fs0 zipWithM_ (addFeatureTree Nothing) fs [(1::Int),3..] ls <- getComponents case featMap of@@ -357,12 +396,12 @@ where baseFKey = idToKey (fst bFeat) - writeFeatMapComp f (compKey, compName) = do+ writeFeatMapComp _ (compKey, _compName) = do addRow (newFeatureComponents [ "Feature_" -=> Just (string baseFKey) , "Component_" -=> Just (string compKey) ]) - writeFeatComp (compKey, compName) = do+ writeFeatComp (compKey, _compName) = do addRow (newFeatureComponents [ "Feature_" -=> Just (string baseFKey) , "Component_" -=> Just (string compKey) ])@@ -370,10 +409,10 @@ addFeatureTree parent tr lab = do case tr of Leaf f -> addFeature parent lab f- Node p@(id,_) fs -> do+ Node p@(i,_) feats -> do addFeature parent lab p- zipWithM_ (\ f u -> addFeatureTree (Just (idToKey id)) f (lab*10+u))- fs+ zipWithM_ (\ f u -> addFeatureTree (Just (idToKey i)) f (lab*10+u))+ feats [(1::Int),3..] addFeature mbParent v (featName, featDesc) = do@@ -381,7 +420,7 @@ addRow (newFeature (("Feature" -=> Just (string featKey)) : (case mbParent of- Just v -> (("Feature_Parent" -=> Just (string v)):)+ Just fp -> (("Feature_Parent" -=> Just (string fp)):) _ -> id) ( [ "Title" -=> Just (string featName) , "Description" -=> Just (string featDesc)@@ -394,10 +433,11 @@ lookupDirectory :: FilePath -> [(FilePath, Id)] -> Maybe Id lookupDirectory fPath ls = lookup fPath ls +findExeComponent :: [(FilePath, String)] -> [(FilePath,String)] -> FilePath -> FilePath findExeComponent dirs comps fpath = -- be a bit flexible here & allow basename of the -- app targets to be used.- let dirs' = dirs ++ mapFst baseName dirs in+ let dirs' = dirs ++ mapFst takeFileName dirs in case lookup fpath dirs' of Just c -> case lookup c (map swap comps) of @@ -406,17 +446,19 @@ Nothing -> fpath _ -> fpath +findDirComponent :: String -> [(String, String)] -> String findDirComponent dir comps = - case lookup dir (map swap comps) of - -- want to map a dir to a comp, so swap (comp,dir) pairs.+ case mbFindDirComponent dir comps of Just x -> x Nothing -- | dir == "TARGETDIR" -> "TARGETDIR" | otherwise -> error ("findDirComponent: couldn't locate " ++ show dir) -- want to map a dir to a comp, so swap (comp,dir) pairs.+mbFindDirComponent :: String -> [(String, String)] -> Maybe String mbFindDirComponent dir comps = lookup dir (map swap comps) +swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- convert a unique (quite possibly, a GUID) Id into the key@@ -453,7 +495,7 @@ addCompMapping cKey "TARGETDIR" mapM_ (writeReg cKey cId) rs where- writeReg cKey cId (RegEntry hive key kAction) = do+ writeReg cKey _cId (RegEntry hive hkey kAction) = do rName <- newId let rKey = idToKey rName (nm, val) = keyAction kAction@@ -468,7 +510,7 @@ addRow (newRemoveRegistry [ "RemoveRegistry" -=> Just (string rKey) , "Root" -=> Just (string (toHiveId hive))- , "Key" -=> Just (string key)+ , "Key" -=> Just (string hkey) , "Name" -=> fmap string nm , "Component_" -=> Just (string cKey) ])@@ -476,7 +518,7 @@ addRow (newRegistry [ "Registry" -=> Just (string rKey) , "Root" -=> Just (string (toHiveId hive))- , "Key" -=> Just (string key)+ , "Key" -=> Just (string hkey) , "Name" -=> fmap string nm , "Value" -=> fmap string val , "Component_" -=> Just (string cKey)@@ -538,9 +580,10 @@ ]) -- and our app folder(s). let dirs = split '/' appFolders+ + createDirs _ [] = error "createDirs: empty list; unexpected.." createDirs pKey [d] = do- i <- newId- let appKey = idToKey i+ appKey <- newId >>= return.idToKey addRow (newDirectory [ "Directory" -=> Just (string appKey) , "Directory_Parent" -=> Just (string pKey)@@ -564,6 +607,7 @@ mapM_ (addShortcut appKey) scuts' +makeShortcutsOptional :: IM () makeShortcutsOptional = do -- Make the installation of shortcuts dependent on _either_ OptStartMenu or -- OptDesktopShortCuts being set to Yes. I don't see how to achieve the@@ -609,34 +653,35 @@ The user refers to the target of the shortcut by (file)name; the MSI wants to know the component (of that file). -}+adjustTarget :: InstallEnv -> Id -> Shortcut -> IM (String, Shortcut) adjustTarget ienv feat s = do dirs <- getDirs comps <- getComponents -- Try interpreting 'scut_target' as a directory relative to the srcDir.- -- The directory list is recorded as relative to 'baseName' of the srcDir,+ -- The directory list is recorded as relative to 'takeFileName' of the srcDir, -- so pin this in front of the user-specified directory.- let bdir = baseName (srcDir ienv)- let t = scut_target s+ let bdir = takeFileName (srcDir ienv)+ let tgt = scut_target s let tdir - | null t = bdir- | otherwise = appendPath bdir t+ | null tgt = bdir+ | otherwise = normalise (bdir </> tgt) -- Note: no need to put a slash between the two (indeed, it's harmful.)- let odir = "[TARGETDIR]" ++ t+ let odir = "[TARGETDIR]" ++ tgt let mbDir = lookupDirectory tdir dirs let mbComp = maybe Nothing (\ v -> mbFindDirComponent v comps) mbDir case mbComp of Just x -> return (odir, s{scut_target=x}) Nothing ->- let t = findExeComponent dirs comps (scut_target s) in- if t == (scut_target s) then do+ let tExe = findExeComponent dirs comps (scut_target s) in+ if tExe == (scut_target s) then do -- couldn't find the component, try locating the file. ls <- getFiles - let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (baseName x, st)) ls- case lookup t ls' of+ let ls' = map (\ st@(x,_) -> (x,st)) ls ++ map (\ st@(x,_) -> (takeFileName x, st)) ls+ case lookup tExe ls' of Nothing -> do- ioToIM (putStrLn ("WARNING: unable to locate target " ++ show t))+ ioToIM (putStrLn ("WARNING: unable to locate target " ++ show tExe)) return (featureKey, s)- Just stuff@(f,(fKey,oldCompKey,nm,fSize)) -> do+ Just (f,(fKey,oldCompKey,_nm,_fSize)) -> do -- create a new component with keypath that points to target. cId <- newId cName <- newId @@ -663,19 +708,18 @@ -- replaceFile f (fKey, cKey, nm, fSize) return (featureKey, s{scut_target=cKey}) else - return (featureKey, s{scut_target=t})+ return (featureKey, s{scut_target=tExe}) where featureKey = idToKey feat addShortcut :: Key -> (String,Shortcut) -> IM () addShortcut appKey (featureKey,s) = do- i <- newId- let key = idToKey i+ sKey <- newId >>= return.idToKey (iKey, idx) <- case (scut_icon s) of Nothing -> return (Nothing, Nothing) Just f -> addIcon f >>= \x -> return (Just (string x), Just (int 0))- addRow (newShortcut [ "Shortcut" -=> Just (string key)+ addRow (newShortcut [ "Shortcut" -=> Just (string sKey) , "Directory_" -=> Just (string appKey) , "Name" -=> Just (string (scut_name s)) , "Component_" -=> Just (string (scut_target s))@@ -692,11 +736,11 @@ addIcon :: String -> IM Key addIcon icoFile = do i <- newId- let key = take 7 (idToKey i) ++ ".exe"- addRow (newIcon [ "Name" -=> Just (string key)+ let iKey = take 7 (idToKey i) ++ ".exe"+ addRow (newIcon [ "Name" -=> Just (string iKey) , "Data" -=> Just (file icoFile) ])- return key+ return iKey setCustomTargetDir :: Maybe String -> String -> IM () setCustomTargetDir def pkgName = do@@ -740,6 +784,7 @@ , newInstallUISequence ] +replaceFinishedText :: Maybe String -> IM () replaceFinishedText Nothing = return () replaceFinishedText (Just str) = do replaceRow ( "Control"@@ -764,6 +809,7 @@ , [ "Text" -=> Just ("{\\VSI_MS_Sans_Serif13.0_0_0}" ++ str) -} +addDestText :: IM () addDestText = do addRow (newControl [ "Dialog_" -=> Just (string "SetupTypeDlg") , "Control" -=> Just (string "InstallDirLabel")@@ -803,6 +849,12 @@ where addV (ext, verb, label, args) = addVerb ext verb label args +addExtension :: Id+ -> String+ -> FilePath+ -> String+ -> String+ -> IM () addExtension feat progId exeFile icoFile ext = do addProgId progId icoFile dirs <- getDirs@@ -816,6 +868,7 @@ , "Feature_" -=> Just (string featureKey) ]) +addVerb :: String -> String -> String -> String -> IM () addVerb ext verb command arg = do addRow (newVerb [ "Extension_" -=> Just (string ext) , "Verb" -=> Just (string verb)@@ -825,6 +878,7 @@ ]) -- given a progID (and its icon), create the ProgId row for it.+addProgId :: String -> String -> IM () addProgId progID icoFile = do rs <- getTableRows "ProgId" let vs = concatMap snd rs@@ -836,15 +890,16 @@ if (not (null ms)) then return () else do- key <- addIcon icoFile+ k <- addIcon icoFile addRow (newProgId [ "ProgId" -=> Just (string progID) -- , "ProgId_Parent" -=> Nothing -- , "Class_" -=> Nothing -- , "Description" -=> Nothing- , "Icon_" -=> Just (string key)+ , "Icon_" -=> Just (string k) , "IconIndex" -=> Just (int 0) ]) +configureLicense :: Maybe FilePath -> IM () configureLicense Nothing = replaceRow ( "Property" , [ ("Property" -=> "ShowLicenseDlg")]@@ -881,12 +936,15 @@ ], [ ("Text", Just (file f)) ]) +setURL :: String -> IM ()+setURL "" = return () setURL url = replaceRow ( "Property" , [ ("Property" -=> "ARPHELPLINK") ] , [ ("Value", Just (string url))] ) +setUserRegistration :: Bool -> IM () setUserRegistration wantIt | wantIt = return () | otherwise = @@ -896,8 +954,8 @@ , [ ("Value", Just (string "0"))] ) --addBannerBitmap nm Nothing = return ()+addBannerBitmap :: String -> Maybe FilePath -> IM ()+addBannerBitmap _ Nothing = return () addBannerBitmap nm (Just bmap) = do addBinary nm bmap replaceRow ( "Property"@@ -905,7 +963,8 @@ , [ ("Value", Just (string nm))] ) -addDialogBitmap nm Nothing = return ()+addDialogBitmap :: String -> Maybe FilePath -> IM ()+addDialogBitmap _ Nothing = return () addDialogBitmap nm (Just bmap) = do addBinary nm bmap replaceRow ( "Property"@@ -913,11 +972,13 @@ , [ ("Value", Just (string nm))] ) +addBinary :: String -> FilePath -> IM () addBinary nm bmap = addRow (newBinary [ "Name" -=> Just (string nm) , "Data" -=> Just (file bmap) ]) +addNestedInstalls :: [(String,Maybe String)] -> IM () addNestedInstalls ss = zipWithM_ addInst ss [0..] where addInst (msiFile, mbOpts) idx = do@@ -938,3 +999,43 @@ [ newAdminExecuteSequence , newInstallExecuteSequence ]++addAssemblies :: Feature -> [Assembly] -> IM ()+addAssemblies feat as = mapM_ (addAssembly feat) as+ +addAssembly :: Feature -> Assembly -> IM ()+addAssembly bFeat a = do+ let featKey = idToKey (fst bFeat)+ dirs <- getDirs+ comps <- getComponents+ let cKey = findExeComponent dirs comps (assem_dll a)+ aKey <- maybe (return Nothing) (\ x -> findExeFile x >>= return.Just) (assem_manifest a)+ addRow (newMsiAssembly+ ([ "Component_" -=> Just (string cKey)+ , "Feature_" -=> Just (string featKey)+ , "File_Manifest" -=> fmap string aKey+ , "File_Application" -=> fmap string (assem_privatePath a)+ , "Attributes" -=> if assem_win32 a then Just (int 1) else Just (int 0)+ ]))+ let+ vs_win32 + | not (assem_win32 a) = [ ("ProcessorArchitecture", "MSIL")]+ | otherwise = + [ ("Type", "win32")+ , ("ProcessorArchitecture", "x86") -- are there any others? ;-)+ ]++ vs =+ [ ("Name", assem_name a)+ , ("Version", assem_version a)+ , ("Culture", (\ x -> if null x then "neutral" else x) $ assem_culture a)+ , ("PublicKeyToken", assem_publicKey a)+ ] ++ vs_win32 + mapM_ (\ (n,v) -> + addRow (newMsiAssemblyName+ [ "Component_" -=> Just (string cKey)+ , "Name" -=> Just (string n)+ , "Value" -=> Just (string v)+ ]))+ vs +
Bamse/PackageUtils.hs view
@@ -16,14 +16,18 @@ import Bamse.Package -import Util.Path ( appendPath, toPlatformPath, fileSuffix )-import System.Path (isSeparator)+import System.FilePath import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import System.Environment import Debug.Trace ( trace ) +import Text.Regex+import Data.Char ( isSpace )+import Data.Maybe+import Data.List+ -- | @toMsiFileName fp@ converts a (base) filename to an MSI output -- filename, appending the .msi suffix + doing away with -- troublesome characters.@@ -35,32 +39,32 @@ dotToDash x = x lFile :: FilePath -> FilePath -> FilePath-lFile dir f = toPlatformPath $ appendPath dir f- -- sigh, Util.Path.appendPath inserts a forward slash, not- -- the platform default one, so we need to normalize the path- -- afterwards.+lFile dir f = normalise (dir </> f) -- classifying files according to their extension/suffix: isHiFile :: FilePath -> Bool isHiFile fn = - case fileSuffix fn of- "hi" -> True- _:'_':'h':'i':[] -> True+ case takeExtension fn of+ ".hi" -> True+ '.':_:'_':'h':'i':[] -> True _ -> False isDocFile :: FilePath -> Bool-isDocFile fn = fileSuffix fn `elem` ["html", "pdf", "dvi", "doc", "ps"]+isDocFile fn = takeExtension fn `elem` [".html", ".pdf", ".dvi", ".doc", ".ps"] isHeaderFile :: FilePath -> Bool-isHeaderFile fn = fileSuffix fn `elem` ["h"]+isHeaderFile fn = takeExtension fn `elem` [".h"] dropDirPrefix :: FilePath -> FilePath -> FilePath-dropDirPrefix [] f = dropWhile isSeparator f+dropDirPrefix [] f = dropWhile isPathSep f dropDirPrefix _ [] = [] dropDirPrefix (x:xs) (y:ys) | x == y = dropDirPrefix xs ys- | otherwise = dropWhile isSeparator (y:ys)+ | otherwise = dropWhile isPathSep (y:ys)+ where +isPathSep :: Char -> Bool+isPathSep c = isPathSeparator c || c == '/' -- to support build-time definitions in strings (via $<FOO>) addEnvVar :: String -> String -> IO ()@@ -151,3 +155,59 @@ where iconDir = lFile bamseDir "icons" +getManifest :: [(String,String)] -> IO (String -> Maybe Bool)+getManifest opts = + case lookup "manifest" opts of+ Just fn -> catch (do { ls <- readFile fn ; return (tryMatch (mapMaybe toRegex $ lines ls))}) + (\ _ -> return (const Nothing))+ Nothing -> return (const Nothing)+ where++ tryMatch [] _ = Nothing+ tryMatch ((flg,x):xs) f = + case matchRegex x f of+ Nothing -> tryMatch xs f+ Just{} -> Just flg++ toRegex "" = Nothing+ toRegex ('#':_) = Nothing+ toRegex r+ | all isSpace r = Nothing+ | otherwise = + -- a single leading '-' indicate that pattern is for exemptions.+ case trim r of+ ('-':xs) -> Just (False,mkRegex xs)+ xs -> Just (True,mkRegex xs)+ + trim s = trimR (dropWhile isSpace s)+ + trimR xs = maybe "" id $ foldr f Nothing xs+ where+ f x (Just acc) = Just (x:acc)+ f x Nothing+ | isSpace x = Nothing+ | otherwise = Just [x]++entryOfInterest :: InstallEnv -> (String -> Maybe Bool) -> FilePath -> Bool+entryOfInterest ienv matcher file+ | defaultJunk file = False+ | null file' = True+ | otherwise = + case maybe True id (matcher file') of+ flg + | traceIt -> trace ((if flg then "including" else "excluding") ++ ": " ++ show (file',file)) flg+ | otherwise -> flg+ where+ file' + | topDir `isPrefixOf` file = canonicalize (drop (length topDir) file)+ | otherwise = file++ topDir = srcDir ienv + traceIt = isJust (lookup "debug" (userOpts ienv))++ canonicalize ('\\':xs) = canonicalize xs+ canonicalize xs = canon1 xs++ canon1 xs = map (\ x -> if x == '\\' then '/' else x) xs++ defaultJunk f = (last f == '~') || (takeFileName f == ".svn")
+ Bamse/Util/Dir.hs view
@@ -0,0 +1,120 @@+{- |+ Module : Bamse.Util.Dir+ Copyright : (c) Sigbjorn Finne, 2002-++ Maintainer : sof@forkIO.com+ Stability : + Portability : + + File system directory utilities.+-}+module Bamse.Util.Dir+ ( -- *Types+ GenDirTree(..)+ , DirTree+ -- * Functions+ , allFiles -- :: FilePath -> IO DirTree+ , findFiles -- :: (FilePath -> Bool) -> FilePath -> IO DirTree+ , findFilesRel -- :: (FilePath -> Bool) -> FilePath -> IO DirTree+ , showDirTree -- :: Maybe Int -> DirTree -> String+ ) where++import Data.Maybe ( fromMaybe )+import Control.Monad ( when )+import System.Directory+import Data.List+--import System.Path+--import Util.Path ( baseName )+import System.FilePath++-- | A tree \/ forest of files.+type DirTree = GenDirTree FilePath++data GenDirTree a+ = File a+ | Directory a [GenDirTree a]+ | Empty+ deriving ( Eq, Show )++instance Functor GenDirTree where+ fmap f (File name) = File (f name)+ fmap f (Directory name ts) = Directory (f name) (map (fmap f) ts)+ fmap _ (Empty) = Empty++-- | @showDirTree mbIndent tree@ shows the directory+-- tree, with each file\/directory appearing on a line+-- of their own. @mbIndent@ controls how much to indent+-- directory entries by. If @Nothing@, entries are indented+-- by two spaces.+showDirTree :: Maybe Int -> DirTree -> String+showDirTree mbIndent d = unlines $ showDir 0 d+ where+ indent_delta = fromMaybe 2 mbIndent++ showDir n Empty = [indent n ""]+ showDir n (File fpath) = [indent n fpath]+ showDir n (Directory nm sub) =+ indent n nm :+ concatMap (showDir (n+indent_delta)) sub++ indent n x = replicate n ' ' ++ x++-- | given a filepath, build up a @DirTree@ containing+-- all files and directories reachable (below that path.)+allFiles :: FilePath -> IO DirTree+allFiles fpath = findFiles (const True) fpath++-- | @findFiles pred path@ builds up a @DirTree@ +-- containing all files\/directories that satisfy+-- the predicate @pred@. The file and directory names+-- in the result appear in full, e.g., if @a.hs@ is+-- a file in the directory @path@, it appears in the+-- result as @(File \"path\/a.hs\"@+findFiles :: (FilePath -> Bool)+ -> FilePath+ -> IO DirTree+findFiles predcsr fpath = findFiles' True predcsr (normalise fpath)++findFiles' :: Bool -> (FilePath -> Bool) -> FilePath -> IO DirTree+findFiles' isTopLevel predcsr fpath+ | not (predcsr fpath) = return Empty+ | otherwise = do+ let findFiles'' = findFiles' False+ isFileThere <- doesFileExist fpath+ isDirThere <- doesDirectoryExist fpath+ case (isFileThere, isDirThere) of+ (True, _) -> return (File fpath)+ (_, True) -> do+ stuff <- getDirectoryContents fpath+ let stuff' = filter (not.isUpDown) stuff+ more_stuff <- mapM (findFiles'' predcsr) (map (fpath </>) stuff')+ let more_stuff' = filter (not.isEmpty) more_stuff+ return (Directory fpath more_stuff')+ (False, False) -> do+ when (isTopLevel)+ (fail $ unwords [ "DirUtils.findFiles: file/directory"+ , fpath+ , "not found."+ ])+ return Empty -- don\'t throw exceptions for broken symlinks+++-- | @findFilesRel pred path@ behaves like @findFiles@, except+-- files and directory names in the result are in /basename/ form,+-- e.g., if @a.hs@ is a file in the directory @path@, it appears+-- in the result as @(File \"a.hs\"@.+findFilesRel :: (FilePath -> Bool)+ -> FilePath+ -> IO DirTree+findFilesRel predcsr fpath = do+ tree <- findFiles predcsr fpath+ return (fmap System.FilePath.takeFileName tree)++isEmpty :: GenDirTree a -> Bool+isEmpty Empty = True+isEmpty _ = False++isUpDown :: String -> Bool+isUpDown "." = True+isUpDown ".." = True+isUpDown _ = False
+ Bamse/Util/GetOpts.hs view
@@ -0,0 +1,206 @@+{- |++ Module : Bamse.Util.GetOpts+ Copyright : (c) Sigbjorn Finne, 2004-++ Maintainer : sof@forkIO.com+ Stability : + Portability : ++ Accumulator-style command-line option parsing; minor extension+ of @System.Console.GetOpt@ (whose interface this module re-exports).+-}++-----------------------------------------------------------------------------+-- No claim to originality here, so include header from original module:+-- +-- Module : System.Console.GetOpt+-- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997)+-- License : BSD-style (see the file libraries/core/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- A Haskell port of GNU's getopt library +--+-----------------------------------------------------------------------------++module Bamse.Util.GetOpts+ ( module System.Console.GetOpt,+ getOpt2 -- :: ArgOrder (a->a) + -- -> [OptDescr (a->a)]+ -- -> [String]+ -- -> a+ -- -> (a,[String],[String])+ , usageInfo2 -- :: String -> [OptDescr a] -> String+ )+where++import Prelude+import Data.List ( isPrefixOf )+import Text.PrettyPrint+import System.Console.GetOpt++{- |+ The @getOpt@ provided @System.Console.GetOpt@ returns a list of+ values representing the options found present in an @argv@-vector.++ @getOpt2@ offers a different view -- the options are represented+ by a single value instead, i.e., you define a labelled field record+ type representing the options supported, and have the OptDescr+ elements just update the contents of that record. This has proven+ to be quite a bit less cumbersome to work with, leaving you at+ the end with a single value (the record) packaging up all the+ options setting.+ + With @getOpt@, you normally end up (essentially) having to+ write a sub parser of the list of values returned, which just+ adds even more bulk to your code, for very little benefit.+-}+getOpt2 :: ArgOrder (a -> a) -- non-option handling+ -> [OptDescr (a -> a)] -- option descriptors+ -> [String] -- the commandline arguments+ -> a -- initial state+ -> (a,[String],[String]) -- (options,non-options,error messages)+getOpt2 _ _ [] st = (st,[],[])+getOpt2 ordering optDescr (arg:args) st = procNextOpt opt ordering+ where procNextOpt (Opt f) _ = (f st',xs,es)+ procNextOpt (NonOpt x) RequireOrder = (st,x:rest,[])+ procNextOpt (NonOpt x) Permute = (st',x:xs,es)+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x st', xs,es)+ procNextOpt EndOfOpts RequireOrder = (st',rest,[])+ procNextOpt EndOfOpts Permute = (st',rest,[])+ procNextOpt EndOfOpts (ReturnInOrder f) = (foldr f st' rest,[],[])+ procNextOpt (OptErr e) _ = (st',xs,e:es)++ (opt,rest) = getNext arg args optDescr+ (st',xs,es) = getOpt2 ordering optDescr rest st++-- getOpt2 supporting code - copied verbatim from System.Console.GetOpt +-- as it isn't exported.++data OptKind a -- kind of cmd line arg (internal use only):+ = Opt a -- an option+ | NonOpt String -- a non-option+ | EndOfOpts -- end-of-options marker (i.e. "--")+ | OptErr String -- something went wrong...++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+ where (opt,arg) = break (=='=') ls+ options = [ o | o@(Option _ xs _ _) <- optDescr,+ l <- xs,+ opt `isPrefixOf` l+ ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = ("--"++opt)++ long (_:_:_) _ rest = (errAmbig options optStr,rest)+ long [NoArg a ] [] rest = (Opt a,rest)+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)+ long [ReqArg _ d] [] [] = (errReq d optStr,[])+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)+ long _ _ rest = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x ys rest1 optDescr = short ads ys rest1+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = '-':[x]++ short (_:_:_) _ rest = (errAmbig options optStr,rest)+ short (NoArg a :_) [] rest = (Opt a,rest)+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)+ short [] [] rest = (errUnrec optStr,rest)+ short [] xs rest = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr =+ OptErr $ usageInfo header ods+ where header = "option '" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr =+ OptErr $ "option '" ++ optStr ++ "' requires an argument " ++ d++errUnrec :: String -> OptKind a+errUnrec optStr =+ OptErr $ "unrecognized option '" ++ optStr ++ "'"++errNoArg :: String -> OptKind a+errNoArg optStr =+ OptErr $ "option '" ++ optStr ++ "' doesn't allow an argument"++usageInfo2 :: String -- header+ -> [OptDescr a] -- option descriptors+ -> String -- nicely formatted decription of options+usageInfo2 header optDescr = render $ vcat $ text header : table+ where+ (ss, ls, descs) = unzip3 $ map fmtOpt optDescr+ table = + let (c1, ssd) = sameLen ss+ (c2, lsd) = sameLen ls+ in+ zipWith3 (paste (74 - c1 - c2)) ssd lsd descs+ paste c3 x y z = nest 2 $ x <+> space <> y <> space <+> fitText c3 z+ sameLen xs =+ let width = maximum $ map length xs+ in+ (width, flushLeft width xs)+ flushLeft n xs = [ text $ take n (x ++ repeat ' ') | x <- xs ]++ fmtOpt :: OptDescr a -> (String, String, String)+ fmtOpt (Option sos los argdesc descr) =+ ( render $ hcat $ punctuate comma $ map (fmtShort argdesc) sos + , render $ hcat $ punctuate comma $ map (fmtLong argdesc) los+ , descr+ )+ where+ fmtShort :: ArgDescr a -> Char -> Doc+ fmtShort (NoArg _ ) so = char '-' <> char so+ fmtShort (ReqArg _ ad) so = char '-' <> char so <+> text ad+ fmtShort (OptArg _ ad) so = char '-' <> char so <+> brackets (text ad)++ fmtLong :: ArgDescr a -> String -> Doc+ fmtLong (NoArg _ ) lo = text "--" <> text lo+ fmtLong (ReqArg _ ad) lo = text "--" <> text lo <> equals <> text ad+ fmtLong (OptArg _ ad) lo = text "--" <> text lo <> equals <>+ brackets (text ad)++-- | Simple line formatting of a paragraph, introducing line breaks+-- whenever length exceeds that of the first argument.+fitText :: Int -> String -> Doc+fitText width s = + vcat $ map (hsep . (map text))+ (fit 0 [] (words s))+ where+ -- fill up lines left-to-right, introducing line breaks + -- whenever line length exceeds 'width'.+ fit :: Int -> [String] -> [String] -> [[String]]+ fit _ acc [] = [reverse acc]+ fit n acc (w:ws)+ | (n + l) >= width = (reverse (w:acc)) : fit 0 [] ws+ | otherwise = fit (n+l+1{-word space-}) (w:acc) ws+ where+ l = length w+
+ Bamse/Util/List.hs view
@@ -0,0 +1,96 @@+{- |++ Module : Bamse.Util.List+ Copyright : (c) Sigbjorn Finne, 2001-++ Maintainer : sof@forkIO.com+ Stability :+ Portability :++ List routines needed by Bamse.+-}+module Bamse.Util.List+ ( split -- :: (Eq a) => a -> [a] -> [[a]]+ , splitBy -- :: (a -> Bool) -> [a] -> [[a]]+ , lookupBy -- :: (a -> Bool) -> [a] -> Maybe a+ , revDropWhile -- :: (a -> Bool) -> [a] -> [a]+ , mapFirstDefault -- :: a -> (a -> Maybe a) -> [a] -> [a]+ , enclose -- :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]++ , mapFst -- :: (a -> b) -> [(a,c)] -> [(b,c)]+ , mapSnd -- :: (a -> b) -> [(c,a)] -> [(c,b)]+ , init0+ , ifCons -- :: Bool -> a -> [a] -> [a]+ + , concatWith -- :: a -> [[a]] -> [a]+ ) where++import Data.List++split :: (Eq a) => a -> [a] -> [[a]]+split elt ls = splitBy (==elt) ls++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy _ [] = []+splitBy p ls =+ case break p ls of+ (bef,[]) -> [bef]+ (bef,_:xs) -> bef : splitBy p xs++--+-- consistent naming, provide 'find' as 'lookupBy'.+--+lookupBy :: (a -> Bool) -> [a] -> Maybe a+lookupBy = find++--+-- revDropWhile p = reverse . dropWhile p . reverse+--+revDropWhile :: (a -> Bool) -> [a] -> [a]+revDropWhile p = foldr f []+ where f x [] | p x = []+ | otherwise = [x]+ f x xs@(_:_) = x:xs++mapFirstDefault :: a+ -> (a -> Maybe a)+ -> [a]+ -> [a]+mapFirstDefault def _ [] = [def]+mapFirstDefault def f (x:xs) =+ case f x of+ Nothing -> x : mapFirstDefault def f xs+ Just x' -> x' : xs++--+-- mapping over just one component of a pair is not that+-- uncommon. As we all know, trivial to write out in terms+-- of 'map', but you shouldn't have to!+--+mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]+mapFst f = map (\ (x,y) -> (f x,y))++mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]+mapSnd f = map (\ (x,y) -> (x,f y))++--+-- add a prefix and a suffix to a list.+--+enclose :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]+enclose p s ls = p ++ (ls ++ s)++init0 :: [a] -> [a]+init0 [] = []+init0 ls = init ls++-- | conditional cons+ifCons :: Bool -> a -> [a] -> [a]+ifCons True x xs = x:xs+ifCons _ _ xs = xs++-- intersperses with the separator before concat'ing+concatWith :: a -> [[a]] -> [a]+concatWith _ [] = []+concatWith sep xss =+ foldr1 ( \ xs yss -> xs ++ (sep : yss) ) xss+
Bamse/WindowsInstaller.hs view
@@ -661,8 +661,8 @@ toEnum v = case v of- 0 -> MsiMessageTypeFatalExit 0 -> MsiMessageTypeOk+ 0 -> MsiMessageTypeFatalExit 0 -> MsiMessageTypeDefault1 1 -> MsiMessageTypeOkCancel 2 -> MsiMessageTypeAbortRetryIgnore
Bamse/Writer.hs view
@@ -41,6 +41,8 @@ -- -> [ReplaceRow] {- rows to replace in the base package -} -- -> IO () , getProductCodes+ + , mergePackage ) where import qualified Prelude@@ -52,18 +54,20 @@ import Data.List import Control.Monad-import System ( system, ExitCode(..) )-import Time ( getClockTime )+import System.Cmd ( system )+import System.Exit ( ExitCode(..) )+import System.Time ( getClockTime ) import Data.Maybe ( fromMaybe, mapMaybe )-import Directory ( removeFile, doesFileExist )+import System.Directory ( removeFile, doesFileExist ) import System.IO import Data.Char ( toUpper ) import Data.Int ( Int32 ) import Data.Bits -import Util.List ( mapFirstDefault, enclose )+import Bamse.Util.List ( mapFirstDefault, enclose ) import System.Win32.Com ( catchComException, throwIOComException )+import System.Win32.Com.Exception ( Com_Exception ) import System.Win32.Com.Automation ( (#), coRun, coCreateObject, isCoError, coGetErrorString,@@ -134,6 +138,7 @@ revC <- si # getProperty0 (fromIntegral $ fromEnum PID_REVNUMBER) return (prodC, revC) +topHandler :: Installer i -> Com_Exception -> IO a topHandler ip err | isCoError err = flip catchComException throwIOComException $ do let v = coGetErrorString err@@ -165,12 +170,12 @@ map (\ ls@((tnm,sz,_):_) -> (tnm, sz, concatMap (\ (_,_,xs) -> xs) ls)) $ groupBy (\ (t1,_,_) (t2,_,_) -> t1 == t2) ts - toRowData (tnm, rows) = + toRowData (tnm, rows1) = case lookup tnm tables of Just cols -> Just ( tnm , length cols- , map (\ (tnm, vals) -> mapMaybe (toIdx tnm cols) vals) rows+ , map (\ (tnm1, vals) -> mapMaybe (toIdx tnm1 cols) vals) rows1 ) Nothing -> trace ("storeTables: WARNING: unknown table " ++ tnm) $ Nothing@@ -183,11 +188,11 @@ show (nm,tabNm)) $ Nothing - addRow rows row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows+ addRow rows1 row@(tn,_) = mapFirstDefault (tn,[row]) (f row) rows1 where- f tab@(tnm,_) (tn,rs2) - | tn == tnm = Just (tnm, tab : rs2)- | otherwise = Nothing+ f tab@(tnm,_) (tn2,rs2) + | tn2 == tnm = Just (tnm, tab : rs2)+ | otherwise = Nothing -- currently assume that the tables passed -- in aren't 100% complete. (This isn't a good@@ -245,7 +250,8 @@ String s -> rec # setStringData idx s Int i -> rec # setIntegerData idx (fromIntegral i) Long l -> rec # setIntegerData idx (fromIntegral l)- File f -> catchComException+ Bamse.MSITable.File f + -> catchComException (rec # setStream idx f) (\ exn -> do hPutStrLn stderr ("Unable to store file: " ++ show f)@@ -325,13 +331,13 @@ -> View b -> (String,String) -> IO ()-setPair inst view (name,val) = do+setPair inst view (nm,val) = do rec <- inst # createRecord 2- rec # setStringData 1 name+ rec # setStringData 1 nm rec # setStringData 2 val catchComException (view # execute rec)- (\ e -> putStrLn ("setPair failed: " ++ name) >> throwIOComException e)+ (\ e -> putStrLn ("setPair failed: " ++ nm) >> throwIOComException e) return () setSummaryInformation :: [(ProductIDTag, String)]@@ -405,7 +411,7 @@ -- just copy that single file (base.msi) instead. -- createBasePackage :: FilePath -> FilePath -> FilePath -> IO ()-createBasePackage bamseDir tDir dest = +createBasePackage _bamseDir tDir dest = copyFile (tDir ++ "\\base.msi") dest {-was: copyFile (src ++ "\\Schema.msi") dest@@ -425,7 +431,7 @@ -> String -> Installer a -> IO ()-mergePackage src dest db ip = do+mergePackage src dest _db ip = do db1 <- ip # openDatabase src (fromEnum MsiOpenDatabaseModeTransact) db2 <- ip # openDatabase dest (fromEnum MsiOpenDatabaseModeReadOnly) let errorTable = "_MergeErrors"@@ -515,11 +521,12 @@ -- just ignore return ()) where- setField rec idx (_,Nothing) = return ()- setField rec idx (_,Just val) = + setField _rec _idx (_,Nothing) = return ()+ setField rec idx (_,Just val) = case val of String s -> rec # setStringData idx s- File f -> do+ Bamse.MSITable.File f+ -> do h <- openFile f ReadMode -- (BinaryMode ReadMode) str <- hGetContents h rec # setStringData idx str@@ -544,6 +551,7 @@ (ioError (userError "no records selected")) return (rec, view) +selectStmt :: String -> [(String,a)] -> [(String,String)] -> String selectStmt tabName vals ls = unwords ([ "SELECT" , unwords fields@@ -555,7 +563,7 @@ fields = intersperse ", " (map (backTick.fst) vals) stuff = intersperse "AND" (map eq ls) - eq (colNm, key) = unwords [backTick colNm, "=", fwdTick key]+ eq (colNm, val) = unwords [backTick colNm, "=", fwdTick val] makeCab :: FilePath -> FilePath@@ -578,23 +586,23 @@ when (fromEnum stat /= fromEnum MsiDoActionStatusSuccess) (hPutStrLn stderr "makeCab: CostInitialize failed") -- sequence the File table- view <- db # openView "SELECT Sequence,Attributes FROM File"+ fView <- db # openView "SELECT Sequence,Attributes FROM File" catchComException- (view # execute ())+ (fView # execute ()) (\ e -> putStrLn "File selection failed" >> throwIOComException e) let- findSeq lSeq = do- rec <- view # fetch+ findSeq theView lSeq = do+ rec <- theView # fetch if (isNullInterface rec) then return lSeq else do- seq <- rec # getIntegerData 1- att <- rec # getIntegerData 2- findSeq (if ((att .&. 0x00004000) == 0) && (seq > lSeq) then seq else lSeq)- lSeq <- findSeq 0- view <- db # openView "SELECT File,FileName,Directory_,Sequence,File.Attributes FROM File,Component WHERE Component_=Component ORDER BY Directory_"+ seqNo <- rec # getIntegerData 1+ att <- rec # getIntegerData 2+ findSeq theView (if ((att .&. 0x00004000) == 0) && (seqNo > lSeq) then seqNo else lSeq)+ lSeq <- findSeq fView 0+ dView <- db # openView "SELECT File,FileName,Directory_,Sequence,File.Attributes FROM File,Component WHERE Component_=Component ORDER BY Directory_" catchComException- (view # execute ())+ (dView # execute ()) (\ e -> putStrLn "Directory selection failed" >> throwIOComException e) let ddfFile = bName ++ ".ddf" hFile <- openFile ddfFile WriteMode@@ -618,11 +626,11 @@ , ".Set Cabinet=ON" ]) let- relabelFiles :: Int32 -> Bool -> [String] -> IO (Int32, Bool, [String])- relabelFiles lSeq addedFiles msgs = do- rec <- view # fetch+ relabelFiles :: View () -> Int32 -> Bool -> [String] -> IO (Int32, Bool, [String])+ relabelFiles theView labSeq addedFiles msgs = do+ rec <- theView # fetch if (isNullInterface rec) then- return (lSeq, addedFiles, msgs)+ return (labSeq, addedFiles, msgs) else do fKey <- rec # getStringData 1 fName <- rec # getStringData 2@@ -632,12 +640,12 @@ if (attrs .&. 0x00002000) == 0 then do -- uncompressed. lSeq' <- do- if sequ <= lSeq then do- rec # setIntegerData 4 (lSeq + 1)- view # modify MsiViewModifyUpdate rec- return (lSeq + 1)+ if sequ <= labSeq then do+ rec # setIntegerData 4 (labSeq + 1)+ theView # modify MsiViewModifyUpdate rec+ return (labSeq + 1) else- return lSeq+ return labSeq let (short,long') = break (=='|') fName let fName' | null short = fName@@ -651,10 +659,10 @@ let sourcePath = sPath ++ fName' hPutStrLn hFile ("\"" ++ sourcePath ++ "\" " ++ fKey) st <- ip # fileAttributes sourcePath- relabelFiles lSeq' True (if st == -1 then (sourcePath : msgs) else msgs)+ relabelFiles theView lSeq' True (if st == -1 then (sourcePath : msgs) else msgs) else do- relabelFiles lSeq True msgs- (lSeq, addedFiles, msgs) <- relabelFiles lSeq False []+ relabelFiles theView labSeq True msgs+ (lSeq1, addedFiles, msgs) <- relabelFiles dView lSeq False [] hClose hFile when (not (null msgs)) (hPutStrLn stderr ("The following files were not available:" ++ show (unlines msgs)))@@ -669,19 +677,19 @@ ] when (rc /= ExitSuccess) (hPutStrLn stderr "makecab failed")- view <- db # openView "SELECT DiskId, LastSequence, Cabinet FROM Media ORDER BY DiskId"- view # execute ()- rec <- view # fetch - (rec,uMode) <-- if (isNullInterface rec) then do- rec <- ip # createRecord 3- rec # setIntegerData 1 1- return (rec, MsiViewModifyInsert)+ mView <- db # openView "SELECT DiskId, LastSequence, Cabinet FROM Media ORDER BY DiskId"+ mView # execute ()+ rec0 <- mView # fetch + (rec2,uMode) <-+ if (isNullInterface rec0) then do+ rec1 <- ip # createRecord 3+ rec1 # setIntegerData 1 1+ return (rec1, MsiViewModifyInsert) else- return (rec, MsiViewModifyUpdate)- rec # setIntegerData 2 lSeq- rec # setStringData 3 cabName- view # modify uMode rec+ return (rec0, MsiViewModifyUpdate)+ rec2 # setIntegerData 2 lSeq1+ rec2 # setStringData 3 cabName+ mView # modify uMode rec2 sumInfo <- db # getSummaryInformation (3::Int32) n <- now sumInfo # setProperty0 11 n@@ -689,13 +697,14 @@ sumInfo # setProperty0 15 (if shortNames then (3::Int32) else 2) sumInfo # persist - view <- db # openView "SELECT `Name`,`Data` FROM _Streams"- view # execute ()- rec <- ip # createRecord 2- rec # setStringData 1 cabFile- rec # setStream 2 cabFile- view # modify MsiViewModifyAssign rec+ sView <- db # openView "SELECT `Name`,`Data` FROM _Streams"+ sView # execute ()+ rec3 <- ip # createRecord 2+ rec3 # setStringData 1 cabFile+ rec3 # setStream 2 cabFile+ sView # modify MsiViewModifyAssign rec3 return ()+ -- remove residuals. removeFile "cabber.INF" `catch` (\ _ -> return ()) removeFile "cabber.ddf" `catch` (\ _ -> return ())
Main.hs view
@@ -1,16 +1,24 @@+{-# OPTIONS_GHC -XCPP #-} +-------------------------------------------------------------------- +-- | +-- Module : Bamse.Package +-- Description : Description of an MSI package/product. +-- Copyright : (c) Sigbjorn Finne, 2004-2009 +-- License : BSD3 -- --- (c) 2007, Galois, Inc. +-- Maintainer : Sigbjorn Finne <sof@forkIO.com> +-- Stability : provisional +-- Portability : portable -- -- Main module for an installer creator. -- +-------------------------------------------------------------------- module Main ( main ) where import Bamse.Package import Bamse.Builder -{- BEGIN_CPP import PACKAGE as PackageSrc - ELSE_NO_CPP -} {- This tool currently gets the package specification from a Haskell module -- see templates/Base.hs for the signature @@ -20,15 +28,15 @@ --import HDirectLib as PackageSrc --import ComPkg as PackageSrc --import GaloisPkg as PackageSrc -import Cryptol as PackageSrc +--import Cryptol as PackageSrc --import Bamse as PackageSrc --import GHC as PackageSrc --import Happy as PackageSrc --import HCDSA as PackageSrc --import Hugs98 as PackageSrc --import Hugs98Net as PackageSrc +--import HsDotnet as PackageSrc --import Base as PackageSrc -{- END_CPP -} main :: IO () main = genBuilder pkg_data @@ -58,7 +66,9 @@ , p_finalMessage = PackageSrc.finalMessage , p_notForAll = PackageSrc.userInstall , p_services = PackageSrc.services - , p_ghcPackage = PackageSrc.ghcPackageInfo +-- , p_ghcPackage = PackageSrc.ghcPackageInfo + , p_cabalPackage = PackageSrc.cabalPackageInfo , p_nestedInstalls = PackageSrc.nestedInstalls + , p_assemblies = PackageSrc.assemblies }
− System/Path.hs
@@ -1,45 +0,0 @@-{- |- - Module : System.Path- Copyright : (c) Galois Connections 2001-2004-- Maintainer : lib@galois.com- Stability : - Portability : - - Platform specific path definitions.--}-module System.Path- ( pathSep -- :: Char- , canonPath -- :: String -> String- , isPathSeparator -- :: Char -> Bool- , drivePath -- :: FilePath -> Maybe Char- , isSeparator -- :: Char -> Bool- ) where---- | preferred path separator for the platform.-pathSep :: Char-pathSep = '\\'---- | given a filepath, POSIX or otherwise, convert it into a--- platform-friendly form.-canonPath :: FilePath -> FilePath-canonPath xs = map toBwd xs- where toBwd '/' = '\\'- toBwd x = x---- | returns 'True' if character is a separator\/divider in a filepath.-isSeparator :: Char -> Bool-isSeparator = isPathSeparator---- deprecated (but I'll resist the temptation of--- adding an annoying deprecated pragma.)-isPathSeparator :: Char -> Bool-isPathSeparator '/' = True-isPathSeparator '\\' = True-isPathSeparator _ = False---- | return drive portion part of path, if any (and meaningful.)-drivePath :: FilePath -> Maybe Char-drivePath (x:':':s:_) | isPathSeparator s = Just x-drivePath _ = Nothing
− Util/Dir.hs
@@ -1,120 +0,0 @@-{- |- - Module : Util.Dir- Copyright : (c) Galois Connections 2002-- Maintainer : lib@galois.com- Stability : - Portability : - - File system directory utilities.--}-module Util.Dir- ( -- *Types- GenDirTree(..)- , DirTree- -- * Functions- , allFiles -- :: FilePath -> IO DirTree- , findFiles -- :: (FilePath -> Bool) -> FilePath -> IO DirTree- , findFilesRel -- :: (FilePath -> Bool) -> FilePath -> IO DirTree- , showDirTree -- :: Maybe Int -> DirTree -> String- ) where--import Data.Maybe ( fromMaybe )-import Control.Monad ( when )-import System.Directory-import Data.List-import System.Path-import Util.Path ( baseName )---- | A tree \/ forest of files.-type DirTree = GenDirTree FilePath--data GenDirTree a- = File a- | Directory a [GenDirTree a]- | Empty- deriving ( Eq, Show )--instance Functor GenDirTree where- fmap f (File name) = File (f name)- fmap f (Directory name ts) = Directory (f name) (map (fmap f) ts)- fmap _ (Empty) = Empty---- | @showDirTree mbIndent tree@ shows the directory--- tree, with each file\/directory appearing on a line--- of their own. @mbIndent@ controls how much to indent--- directory entries by. If @Nothing@, entries are indented--- by two spaces.-showDirTree :: Maybe Int -> DirTree -> String-showDirTree mbIndent d = unlines $ showDir 0 d- where- indent_delta = fromMaybe 2 mbIndent-- showDir n Empty = [indent n ""]- showDir n (File fpath) = [indent n fpath]- showDir n (Directory nm sub) =- indent n nm :- concatMap (showDir (n+indent_delta)) sub-- indent n x = replicate n ' ' ++ x---- | given a filepath, build up a @DirTree@ containing--- all files and directories reachable (below that path.)-allFiles :: FilePath -> IO DirTree-allFiles fpath = findFiles (const True) fpath---- | @findFiles pred path@ builds up a @DirTree@ --- containing all files\/directories that satisfy--- the predicate @pred@. The file and directory names--- in the result appear in full, e.g., if @a.hs@ is--- a file in the directory @path@, it appears in the--- result as @(File \"path\/a.hs\"@-findFiles :: (FilePath -> Bool)- -> FilePath- -> IO DirTree-findFiles predcsr fpath = findFiles' True predcsr fpath--findFiles' :: Bool -> (FilePath -> Bool) -> FilePath -> IO DirTree-findFiles' isTopLevel predcsr fpath- | not (predcsr fpath) = return Empty- | otherwise = do- let findFiles'' = findFiles' False- isFileThere <- doesFileExist fpath- isDirThere <- doesDirectoryExist fpath- case (isFileThere, isDirThere) of- (True, _) -> return (File fpath)- (_, True) -> do- stuff <- getDirectoryContents fpath- let stuff' = filter (not.isUpDown) stuff- more_stuff <- mapM (findFiles'' predcsr) (map (\ x -> fpath++[pathSep]++ x) stuff')- let more_stuff' = filter (not.isEmpty) more_stuff- return (Directory fpath more_stuff')- (False, False) -> do- when (isTopLevel)- (fail $ unwords [ "DirUtils.findFiles: file/directory"- , fpath- , "not found."- ])- return Empty -- don\'t throw exceptions for broken symlinks----- | @findFilesRel pred path@ behaves like @findFiles@, except--- files and directory names in the result are in /basename/ form,--- e.g., if @a.hs@ is a file in the directory @path@, it appears--- in the result as @(File \"a.hs\"@.-findFilesRel :: (FilePath -> Bool)- -> FilePath- -> IO DirTree-findFilesRel predcsr fpath = do- tree <- findFiles predcsr fpath- return (fmap baseName tree)--isEmpty :: GenDirTree a -> Bool-isEmpty Empty = True-isEmpty _ = False--isUpDown :: String -> Bool-isUpDown "." = True-isUpDown ".." = True-isUpDown _ = False
− Util/GetOpts.hs
@@ -1,206 +0,0 @@-{- |-- Module : Util.GetOpts- Copyright : (c) Galois Connections, 2004-- Maintainer : lib@galois.com- Stability : - Portability : -- Accumulator-style command-line option parsing; minor extension- of @System.Console.GetOpt@ (whose interface this module re-exports).--}---------------------------------------------------------------------------------- No claim to originality here, so include header from original module:--- --- Module : System.Console.GetOpt--- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997)--- License : BSD-style (see the file libraries/core/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ A Haskell port of GNU's getopt library -----------------------------------------------------------------------------------module Util.GetOpts- ( module System.Console.GetOpt,- getOpt2 -- :: ArgOrder (a->a) - -- -> [OptDescr (a->a)]- -- -> [String]- -- -> a- -- -> (a,[String],[String])- , usageInfo2 -- :: String -> [OptDescr a] -> String- )-where--import Prelude-import Data.List ( isPrefixOf )-import Text.PrettyPrint-import System.Console.GetOpt--{- |- The @getOpt@ provided @System.Console.GetOpt@ returns a list of- values representing the options found present in an @argv@-vector.-- @getOpt2@ offers a different view -- the options are represented- by a single value instead, i.e., you define a labelled field record- type representing the options supported, and have the OptDescr- elements just update the contents of that record. This has proven- to be quite a bit less cumbersome to work with, leaving you at- the end with a single value (the record) packaging up all the- options setting.- - With @getOpt@, you normally end up (essentially) having to- write a sub parser of the list of values returned, which just- adds even more bulk to your code, for very little benefit.--}-getOpt2 :: ArgOrder (a -> a) -- non-option handling- -> [OptDescr (a -> a)] -- option descriptors- -> [String] -- the commandline arguments- -> a -- initial state- -> (a,[String],[String]) -- (options,non-options,error messages)-getOpt2 _ _ [] st = (st,[],[])-getOpt2 ordering optDescr (arg:args) st = procNextOpt opt ordering- where procNextOpt (Opt f) _ = (f st',xs,es)- procNextOpt (NonOpt x) RequireOrder = (st,x:rest,[])- procNextOpt (NonOpt x) Permute = (st',x:xs,es)- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x st', xs,es)- procNextOpt EndOfOpts RequireOrder = (st',rest,[])- procNextOpt EndOfOpts Permute = (st',rest,[])- procNextOpt EndOfOpts (ReturnInOrder f) = (foldr f st' rest,[],[])- procNextOpt (OptErr e) _ = (st',xs,e:es)-- (opt,rest) = getNext arg args optDescr- (st',xs,es) = getOpt2 ordering optDescr rest st---- getOpt2 supporting code - copied verbatim from System.Console.GetOpt --- as it isn't exported.--data OptKind a -- kind of cmd line arg (internal use only):- = Opt a -- an option- | NonOpt String -- a non-option- | EndOfOpts -- end-of-options marker (i.e. "--")- | OptErr String -- something went wrong...---- take a look at the next cmd line arg and decide what to do with it-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr-getNext a rest _ = (NonOpt a,rest)---- handle long option-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-longOpt ls rs optDescr = long ads arg rs- where (opt,arg) = break (=='=') ls- options = [ o | o@(Option _ xs _ _) <- optDescr,- l <- xs,- opt `isPrefixOf` l- ]- ads = [ ad | Option _ _ ad _ <- options ]- optStr = ("--"++opt)-- long (_:_:_) _ rest = (errAmbig options optStr,rest)- long [NoArg a ] [] rest = (Opt a,rest)- long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)- long [ReqArg _ d] [] [] = (errReq d optStr,[])- long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)- long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)- long [OptArg f _] [] rest = (Opt (f Nothing),rest)- long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)- long _ _ rest = (errUnrec optStr,rest)---- handle short option-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])-shortOpt x ys rest1 optDescr = short ads ys rest1- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]- ads = [ ad | Option _ _ ad _ <- options ]- optStr = '-':[x]-- short (_:_:_) _ rest = (errAmbig options optStr,rest)- short (NoArg a :_) [] rest = (Opt a,rest)- short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])- short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)- short (ReqArg f _:_) xs rest = (Opt (f xs),rest)- short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)- short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)- short [] [] rest = (errUnrec optStr,rest)- short [] xs rest = (errUnrec optStr,('-':xs):rest)---- miscellaneous error formatting--errAmbig :: [OptDescr a] -> String -> OptKind a-errAmbig ods optStr =- OptErr $ usageInfo header ods- where header = "option '" ++ optStr ++ "' is ambiguous; could be one of:"--errReq :: String -> String -> OptKind a-errReq d optStr =- OptErr $ "option '" ++ optStr ++ "' requires an argument " ++ d--errUnrec :: String -> OptKind a-errUnrec optStr =- OptErr $ "unrecognized option '" ++ optStr ++ "'"--errNoArg :: String -> OptKind a-errNoArg optStr =- OptErr $ "option '" ++ optStr ++ "' doesn't allow an argument"--usageInfo2 :: String -- header- -> [OptDescr a] -- option descriptors- -> String -- nicely formatted decription of options-usageInfo2 header optDescr = render $ vcat $ text header : table- where- (ss, ls, descs) = unzip3 $ map fmtOpt optDescr- table = - let (c1, ssd) = sameLen ss- (c2, lsd) = sameLen ls- in- zipWith3 (paste (74 - c1 - c2)) ssd lsd descs- paste c3 x y z = nest 2 $ x <+> space <> y <> space <+> fitText c3 z- sameLen xs =- let width = maximum $ map length xs- in- (width, flushLeft width xs)- flushLeft n xs = [ text $ take n (x ++ repeat ' ') | x <- xs ]-- fmtOpt :: OptDescr a -> (String, String, String)- fmtOpt (Option sos los argdesc descr) =- ( render $ hcat $ punctuate comma $ map (fmtShort argdesc) sos - , render $ hcat $ punctuate comma $ map (fmtLong argdesc) los- , descr- )- where- fmtShort :: ArgDescr a -> Char -> Doc- fmtShort (NoArg _ ) so = char '-' <> char so- fmtShort (ReqArg _ ad) so = char '-' <> char so <+> text ad- fmtShort (OptArg _ ad) so = char '-' <> char so <+> brackets (text ad)-- fmtLong :: ArgDescr a -> String -> Doc- fmtLong (NoArg _ ) lo = text "--" <> text lo- fmtLong (ReqArg _ ad) lo = text "--" <> text lo <> equals <> text ad- fmtLong (OptArg _ ad) lo = text "--" <> text lo <> equals <>- brackets (text ad)---- | Simple line formatting of a paragraph, introducing line breaks--- whenever length exceeds that of the first argument.-fitText :: Int -> String -> Doc-fitText width s = - vcat $ map (hsep . (map text))- (fit 0 [] (words s))- where- -- fill up lines left-to-right, introducing line breaks - -- whenever line length exceeds 'width'.- fit :: Int -> [String] -> [String] -> [[String]]- fit _ acc [] = [reverse acc]- fit n acc (w:ws)- | (n + l) >= width = (reverse (w:acc)) : fit 0 [] ws- | otherwise = fit (n+l+1{-word space-}) (w:acc) ws- where- l = length w-
− Util/List.hs
@@ -1,97 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{- |-- Module : Util.List- Copyright : (c) Galois Connections 2001, 2002-- Maintainer : lib@galois.com- Stability :- Portability :-- List routines needed by Bamse.--}-module Util.List- ( split -- :: (Eq a) => a -> [a] -> [[a]]- , splitBy -- :: (a -> Bool) -> [a] -> [[a]]- , lookupBy -- :: (a -> Bool) -> [a] -> Maybe a- , revDropWhile -- :: (a -> Bool) -> [a] -> [a]- , mapFirstDefault -- :: a -> (a -> Maybe a) -> [a] -> [a]- , enclose -- :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]-- , mapFst -- :: (a -> b) -> [(a,c)] -> [(b,c)]- , mapSnd -- :: (a -> b) -> [(c,a)] -> [(c,b)]- , init0- , ifCons -- :: Bool -> a -> [a] -> [a]- - , concatWith -- :: a -> [[a]] -> [a]- ) where--import Data.List--split :: (Eq a) => a -> [a] -> [[a]]-split elt ls = splitBy (==elt) ls--splitBy :: (a -> Bool) -> [a] -> [[a]]-splitBy _ [] = []-splitBy p ls =- case break p ls of- (bef,[]) -> [bef]- (bef,_:xs) -> bef : splitBy p xs------- consistent naming, provide 'find' as 'lookupBy'.----lookupBy :: (a -> Bool) -> [a] -> Maybe a-lookupBy = find------- revDropWhile p = reverse . dropWhile p . reverse----revDropWhile :: (a -> Bool) -> [a] -> [a]-revDropWhile p = foldr f []- where f x [] | p x = []- | otherwise = [x]- f x xs@(_:_) = x:xs--mapFirstDefault :: a- -> (a -> Maybe a)- -> [a]- -> [a]-mapFirstDefault def _ [] = [def]-mapFirstDefault def f (x:xs) =- case f x of- Nothing -> x : mapFirstDefault def f xs- Just x' -> x' : xs------- mapping over just one component of a pair is not that--- uncommon. As we all know, trivial to write out in terms--- of 'map', but you shouldn't have to!----mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]-mapFst f = map (\ (x,y) -> (f x,y))--mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]-mapSnd f = map (\ (x,y) -> (x,f y))------- add a prefix and a suffix to a list.----enclose :: [a{-pre-}] -> [a{-suff-}] -> [a{-list-}] -> [a]-enclose p s ls = p ++ (ls ++ s)--init0 :: [a] -> [a]-init0 [] = []-init0 ls = init ls---- | conditional cons-ifCons :: Bool -> a -> [a] -> [a]-ifCons True x xs = x:xs-ifCons _ _ xs = xs---- intersperses with the separator before concat'ing-concatWith :: a -> [[a]] -> [a]-concatWith _ [] = []-concatWith sep xss =- foldr1 ( \ xs yss -> xs ++ (sep : yss) ) xss-
− Util/Path.hs
@@ -1,256 +0,0 @@-{- |- - Module : Util.Path- Copyright : (c) Galois Connections 2001, 2002-- Maintainer : lib@galois.com- Stability : - Portability : - - Working with file system paths.--}-module Util.Path- ( module System.Path- , buildPath -- :: String -> [FilePath] -> FilePath- , toAbsolutePath -- :: FilePath -> FilePath -> FilePath- , toRelativePath -- :: FilePath -> FilePath -> FilePath- , dirName -- :: FilePath -> FilePath- , baseName -- :: FilePath -> FilePath- , dropSuffix -- :: FilePath -> FilePath- , changeSuffix -- :: String -> FilePath -> FilePath- , fileSuffix -- :: FilePath -> String- , splitPath -- :: FilePath -> [String]- , splitPath2 -- :: FilePath -> [FilePath]- , initsPath -- :: FilePath -> [FilePath]- , joinPath -- :: [String] -> FilePath- , dirname -- :: FilePath -> FilePath- , appendSep -- :: FilePath -> FilePath- , appendSepPosix -- :: FilePath -> FilePath- , dropSepTrail -- :: FilePath -> FilePath- , appendPath -- :: FilePath -> FilePath -> FilePath- , appendPathPosix -- :: FilePath -> FilePath -> FilePath- , prefixDir -- :: String -> String -> String-- , toPosixPath -- :: FilePath -> FilePath- , toPlatformPath -- :: FilePath -> FilePath- ) where--import Data.List--import Util.List ( revDropWhile, init0 )-import System.Path---- | @buildPath sep paths@ joins together @paths@, interspersed--- by @sep@.-buildPath :: String -> [FilePath] -> String-buildPath sep = concat . intersperse sep---- | @splitPath p@ breaks up the file path @p@ into parts--- separated by 'System.Path.isSeparator'--- --- @--- splitPath \"c:\/foo\/bar\/baz\/my.c\" = [\"c:\", \"foo\", \"bar\", \"baz\", \"my.c\"]--- splitPath \"\/foo\/\/\/bar\/\/\" = [\"\", \"foo\", \"bar\"]--- @-splitPath :: FilePath -> [String]-splitPath "" = []-splitPath s = d : splitPath (dropWhile isSeparator s')- where (d,s') = break isSeparator s---- | @splitPath2 path@ returns the sub-paths that make--- up @path@.--- --- @--- splitPath \"\/etc\/rc.d\/foo\" = [\"\/\",\"\/etc\", \"\/etc\/rc.d\", \"\/etc\/rc.d\/foo\"]--- @-splitPath2 :: FilePath -> [FilePath]-splitPath2 = map joinPath . tail . inits . splitPath- -- ToDo: give it a better name.---- | @joinPath parts@ constructs a new file path out--- of @parts@, interspersing them by 'System.Path.pathSep'.--- It differs from 'buildPath' in that an empty list of--- @parts@ maps to @.@, and if @parts@ is equal to @[\"\"]@,--- the root directory is returned.--- -joinPath :: [String] -> FilePath-joinPath [] = "."-joinPath [""] = [pathSep]-joinPath ds = concat (intersperse [pathSep] ds)--- The two special cases above look a bit 'odd-hoc' :)----- | @toAbsolutePath curr rel@ returns a new file path--- by navigating from @curr@ using the relative path--- @rel@ . @curr@ is assumed to be an absolute path,--- and @rel@ a relative one.-toAbsolutePath :: FilePath -> FilePath -> FilePath-toAbsolutePath current relative = absolute where- absolute = joinPath (reverse absDirs)- curDirs = reverse (splitPath current)- relDirs = splitPath relative- absDirs = foldl chdir curDirs relDirs- chdir ds ".." = case ds of- [""] -> ds -- toAbsolutePath "/foo" "../../bar" = "/bar"- [] -> [".."] -- toAbsolutePath "foo" "../../bar" = "../bar"- ("..":_) -> "..":ds- (_:ds') -> ds'- chdir ds "." = ds- chdir _ "" = [""]- chdir ds d = d:ds---- | @toRelativePath path1 path2@ computes the relative path--- required to navigate from @path1@ to @path2@.-toRelativePath :: FilePath -> FilePath -> FilePath-toRelativePath current absolute = if null relative then "." else relative where- relative = joinPath relDirs- curDirs = splitPath current- absDirs = splitPath absolute- (curDirs', absDirs') = dropCommonPrefix curDirs absDirs- relDirs = (map (const "..") curDirs') ++ absDirs'- dropCommonPrefix (a:as) (b:bs) | a == b = dropCommonPrefix as bs- dropCommonPrefix as bs = (as,bs)---- | @baseName path@ is the dual to @dirName@, returning the filename--- portion after the last occurrence of a path separator in @path@.--- If @path@ doesn't contain a path separator, @path@ is returned.-baseName :: FilePath -> FilePath-baseName p = findLast isSeparator p p'- where- p' = dropSepTrail p---- | @dirName path@ returns the directory portion of file path @path@,--- i.e., everything upto (and including) the last directory separator.--- If @path@ doesn't contain a path separator, @.\/@ is returned.-dirName :: FilePath -> FilePath-dirName fname =- case revDropWhile (not.isSeparator) (revDropWhile isSeparator fname) of- "" -> "./" -- no separator was found, dir-name is "."- xs -> xs---- | @dirname path@ is identical to 'dirName', except--- if @path@ doesn't contain a path separator, @.@ is--- returned ('dirName' return @.\/@ instead.) @dirname@--- mirrors the Unix "dirname" command.-dirname :: FilePath -> FilePath-dirname = joinPath . init0 . splitPath---- | @dropSepTrail path@ returns @path@ with trailing separators--- stripped from it.-dropSepTrail :: FilePath -> FilePath-dropSepTrail p = go p- where- go [] = []- go (x:xs) - | isSeparator x = case go xs of { [] -> []; ys -> x:ys }- | otherwise = x : go xs---- | Return the file suffix\/file extension. The suffix /does not/--- include the dot. In case there isn't a suffix, return empty string.-fileSuffix :: FilePath -> String-fileSuffix = findLast (=='.') ""--findLast :: (Char -> Bool)- -> String- -> String- -> String-findLast p noMatch f = go False f f- where- go matched acc []- | matched = acc- | otherwise = noMatch- go matched acc (x:xs)- | p x = go True xs xs- | otherwise = go matched acc xs---- | @dropSuffix path@ chops off the file extension of @path@--- (including the dot.) If @path@ doesn't have a file extension,--- @path@ is returned.-dropSuffix :: FilePath -> FilePath-dropSuffix f = replaceSuffixWith "" f---- | @changeSuffix ext path@ changes @path@\'s file extension--- to @ext@. If @path@ doesn't have a file extension, @ext@--- is appended.-changeSuffix :: String -> FilePath -> FilePath-changeSuffix ext f =- replaceSuffixWith (case ext of { '.':_ -> ext ; _ -> '.':ext }) f--replaceSuffixWith :: String -> String -> String-replaceSuffixWith suf fname = - case (go fname) of- (False, xs) -> xs- (True,_) -> fname ++ suf- where- go :: String -> (Bool, String)- go "" = (True, "")- go ('.':'.':x:xs)- | x == pathSep- = (False, '.':'.':x:res)- where- (_, res) = go xs- go (x:xs)- | x == '.' = (False, if isLastDot then suf else x:res)- | otherwise = (isLastDot, x:res)- where- (isLastDot, res) = go xs---- | @appendSepPosix path@ adds a path separator at the end of @path@,--- unless it already has one.-appendSepPosix :: FilePath -> FilePath-appendSepPosix p = appendSep' '/' p---- | @appendSepPosix path@ adds a (platform-specific) path separator at the end of @path@,--- unless it already has one.-appendSep :: FilePath -> FilePath-appendSep p = appendSep' pathSep p---- internal helper function-appendSep' :: Char -> FilePath -> FilePath-appendSep' _ "" = ""-appendSep' s [x]- | isSeparator x = [x]- | otherwise = [x, s]-appendSep' s (x:xs) = x : appendSep' s xs---- | @appendPathPosix path0 path1@ appends @path1@ onto the end of @path0@, --- separating the two using a forward slash.-appendPathPosix :: FilePath -> FilePath -> FilePath-appendPathPosix p0 p1 = (appendSepPosix p0) ++ p1---- | @appendPath path0 path1@ appends @path1@ onto the end of @path0@.-appendPath :: FilePath -> FilePath -> FilePath-appendPath p0 p1 = (appendSep p0) ++ p1---- | @initsPath path@ returns the 'inits' of @path@------ @--- initsPath \"\/foo\/bar\/blah\" == [ \"\/\", \"\/foo\", \"\/foo\/bar\", \"\/foo\/bar\/blah\" ]--- @--initsPath :: FilePath -> [FilePath]-initsPath = splitPath2---- | @toPosixPath path@ normalises the path separators to forward--- slashes. Easier to work with.-toPosixPath :: FilePath -> FilePath-toPosixPath = map subst- where- subst '\\' = '/'- subst x = x---- | @toPlatformPath path@ converts a path into platform-specific form.-toPlatformPath :: FilePath -> FilePath-toPlatformPath = map subst- where- subst x- | isSeparator x = pathSep- | otherwise = x---- | -prefixDir :: FilePath -> FilePath -> FilePath-prefixDir [] rest = rest-prefixDir ['/'] rest = '/':rest-prefixDir ['\\'] rest = '/':rest-prefixDir [x] rest = x:'/':rest-prefixDir (x:xs) rest = x : prefixDir xs rest
bamse.cabal view
@@ -1,18 +1,33 @@ name: bamse -version: 0.9.3 +version: 0.9.4 Synopsis: A Windows Installer (MSI) generator framework Description: Bamse is a framework for building Windows Installers for your Windows applications, giving you a comprehensive set - of features to put together Windows Installers using Haskell. - + of features to put together MSIs using Haskell. + . + Bamse lets you author /installer generators/, i.e., applications + that will generate Windows Installers when invoked (and pointed + at the files and other resources to include for that particular + installer instance.) Bamse is also accessible as a library, letting + you integrate MSI creation into your codebase. + . + The package has a number of example /templates/ showing how to + specify a generator; /real/ examples that have been used to ship + software by a number of projects and companies. See the @templates/@ + directory; one good way to get started is to modify one of these + to suit the needs of the installers you are looking to create. + . + For a worked example of how to build installers from your Cabal packages, + and possibly automatically install them when running the MSI, see @examples/Cabal.hs@ + (and the README in that directory.) category : System license : BSD3 license-file : LICENSE author : Sigbjorn Finne <sof@forkIO.com> maintainer : sof@forkIO.com cabal-version : >= 1.2 -build-type : Simple +build-type : Custom extra-source-files: README license.rtf icons/folder.exe @@ -53,6 +68,8 @@ tools/msiIcon.c tools/README.txt tools/Makefile + tools/Wrapper.hs + tools/custWrap.exe templates/Alex.hs templates/Bamse.hs templates/Base.hs @@ -64,15 +81,35 @@ templates/HDirectLib.hs templates/Haddock.hs templates/Happy.hs + templates/HsDotnet.hs templates/Hugs98.hs templates/Hugs98Net.hs templates/PubCryptol.hs templates/SOE.hs + examples/Cabal.hs + examples/README + tests/Tests.hs flag old-base description: Old, monolithic base default: False +flag build-tests + default: False + +-- +-- To use bamseGen, configure as follows, e.g., +-- +-- Setup configure -fbamseGen --ghc-options=-DPACKAGE=Alex +-- +flag bamseGen + description: Build parameterized installer generator (via PACKAGE define) + default: False + +flag hsdotnet + description: Build HsDotnet installer generator + default: True + library { Exposed-modules: Bamse.Builder, Bamse.DiaWriter, @@ -89,23 +126,47 @@ Bamse.WindowsInstaller, Bamse.Writer - Other-Modules: System.Path, - Util.Dir, - Util.GetOpts, - Util.List, - Util.Path + Other-Modules: Bamse.Util.Dir, + Bamse.Util.GetOpts, + Bamse.Util.List Ghc-Options: -Wall - build-depends: com >= 1.2.2 , haskell98, directory, pretty + build-depends: com >= 1.2.3 , process, directory, pretty, regex-compat, old-time, filepath if flag(old-base) Build-Depends: base < 3 else Build-Depends: base >= 4 } -executable bamse { +executable hsDotnetGen { main-is: Main.hs + CPP-Options: -DPACKAGE=HsDotnet hs-source-dirs: . templates ghc-options: -Wall + if flag(hsdotnet) && !flag(bamseGen) + Buildable: True + else + Buildable: False +} + +executable bamseGen { + main-is: Main.hs +-- CPP-Options: -DPACKAGE=flag(Package) + hs-source-dirs: . templates + ghc-options: -Wall -idist/build + if flag(bamseGen) + Buildable: True + else + Buildable: False +} + +executable runTests { + if flag(build-tests) + buildable: True + else + buildable: False + Main-Is: tests/Tests.hs + build-depends: QuickCheck, HUnit + Hs-Source-Dirs: ., tests }
+ examples/Cabal.hs view
@@ -0,0 +1,150 @@+{- | + Module : Cabal + Description : Building an installer from your Cabal project. + Copyright : (c) Sigbjorn Finne, 2009 + License : BSD3 + + Generating an MSI installer from your Cabal-built Haskell library or + application. + + This is an example of how to take the contents of your Cabal + <http://haskell.org/Cabal/> project and box it up in Windows + Installer form. Along with details specifying the properties + of your package (name, author, project web site etc.) you also + list the files you want to include. Given those two pieces, the + Bamse builder goes to work, outputting in the end a working MSI + that's ready for distribution. +-} +module Main where + +import Bamse.Package +import Bamse.PackageUtils ( dropDirPrefix ) +import Bamse.Builder +import Data.List ( isPrefixOf ) +import System.FilePath + +--import Debug.Trace + +-- | @main@ kicks off the party. To see what command-line options +-- it supports, invoke it with @--help@. +-- +-- Typical invocation: +-- +-- > foo$ genCabal --generate-guids -o myInstaller.msi c:/path/to/the/top/of/my/cabal/pkg +-- > # if you want to re-generate the MSI (but not update its product etc. GUIDs.) +-- > foo$ genCabal -u -o myInstaller.msi c:/path/to/the/top/of/my/cabal/pkg +main :: IO () +main = do + genBuilder pkgCabal + -- alternatively, supply the command-line arguments directly: + -- (this is something you want to do when integrating the Bamse library + -- into your application directly.) + -- genBuilderArgs pkgCabal ["--generate-guids", "-o", "c:/public/deploy/myInst.msi"] + +-- | @pkgCabal@ is the toplevel 'Bamse.Package.PackageData' value, containing +-- all the interesting bits of info that make up an MSI (as seen/supported by Bamse..) +-- We /derive/ it from 'Bamse.Package.minimalPackageData', which supplies default +-- values for most MSI package properties. Here we simply override with the portions +-- relevant to our Cabal example. For more comprehensive and demanding installers, +-- please consult 'Bamse.Package.PackageData' or see the @templates/@ directory for +-- live examples of other installer specifications. +pkgCabal :: PackageData +pkgCabal = minimalPackageData + { p_fileMap = dirTree + , p_defOutFile = defaultOutputFile + , p_pkgInfo = cabalPkgInfo + , p_webSite = webSite + , p_baseFeature = baseFeature + , p_desktopShortcuts = \ _ienv -> [] + -- Note: this needs to be a .rtf file holding your license. If you + -- supply one (after having generated the RTF via wordpad or some such..), + -- the installer will include in its UI a user-agreement form displaying + -- the license text. + , p_license = \ _ -> Nothing + -- Somewhat confusing perhaps, but this field is used to control the + -- on-install running of Cabal itself, letting you automatically install + -- (and possibly) the Cabal package at install-time. (The user is given + -- a choice whether or not to do this in the UI.) We want to do this, + -- but only allow the @install@ step; no support for building from source. + , p_cabalPackage = Just cabalPackage + } + +-- +-- The rest of this module supplies the definitions of the fields that we +-- filled in for @pkgCabal' + +-- +-- First, some overall package information: +-- +pkgName :: String +pkgName = "MyPackage" + +pkgVersion :: String +pkgVersion = "1.2.0" -- major.minor.build[.whatever] + +pkgAuthor :: String +pkgAuthor = "Kap. Abel" + +cabalPkgInfo :: Package +cabalPkgInfo = + Package { name = pkgName + , title = pkgName -- will show up in UI. + , productVersion = pkgVersion + , author = pkgAuthor + , comment = "This is an example package" + } + +-- | @dirTree@ is the function that walks over the directory +-- you point the MSI generator at when running, returning the +-- files and directories to include in the generated MSI. +-- +-- This particular one will include anything inside the build @dist/@ +-- directory + the .cabal, LICENSE and Setup.hs files. We +-- don't consider including the sources here, but doing so +-- is an easy extension (see @templates/@ for examples of this.) +-- +dirTree :: InstallEnv -> IO DirTree +dirTree ienv = findFiles ofInterest topDir + where + topDir = srcDir ienv + ofInterest f = {-trace (show (f_local,res)) -}res + + where + f_local = dropDirPrefix topDir f + res = + null f_local || + "dist" `isPrefixOf` f_local || + takeExtension f_local == ".cabal" || + f_local `elem` package_files + + package_files = ["Setup.hs", "LICENSE", "README", "custWrap.exe"] + +-- | Extra Cabal specific information used to direct installation +-- of the package on the user's machine. +cabalPackage :: CabalPackage +cabalPackage = CabalPackage + { cabal_packageName = name cabalPkgInfo + , cabal_forGhcVersion = "6.10.1" + , cabal_packageFile = Just (name cabalPkgInfo ++ ".cabal") + , cabal_pkgCmdLine = Nothing + , cabal_fromSource = False -- don't support from source building via the MSI. + } + +-- | When invoked the MSI generator can emit the MSI into a default output file. +-- (the @-o@ option is what you would normally use to override this.) +defaultOutputFile :: FilePath +defaultOutputFile = name cabalPkgInfo ++ '-':map subst (productVersion cabalPkgInfo) ++ ".msi" + where + subst '.' = '-' + subst ch = ch + +-- | @webSite@ contains the URL for the package itself. +-- If that doesn't apply to you, its Hackage URL would be good. +webSite :: {-URL-}String +webSite = "http://www.haskell.org/cabal" + +-- | @baseFeature@ is a mostly-internal name, but you need to supply +-- a name. Defaults to @cabalPkgInfo.name@ +baseFeature :: Feature +baseFeature = (name cabalPkgInfo, name cabalPkgInfo ++ " package for GHC") +
+ examples/README view
@@ -0,0 +1,20 @@+Examples: currently only a worked-through example of how +to bundle up your Cabal project in an MSI. + +To build and invoke it, do: + + foo$ cd /to/my/bamse/directory + # Skip building the Bamse package if you already have.. + foo$ runghc Setup configure --user; runghc Setup build; runghc Setup install + foo$ cd examples + foo$ ghc -o genCabal Cabal.hs -package bamse + # Edit the Cabal.hs sources to have it fit your application/package (name, author, files, etc.) + foo$ cd /to/my/cabal/package + foo$ cp /to/my/bamse/directory/examples/genCabal.exe . + foo$ ./genCabal --generate-guids -o myMSI.msi --tool-dir=c:/to/my/bamse/directory . + ... + foo$ cp myMSI.msi c:/public/publish/directory/ + # Uh, you may want to test it some first ;-) + + +
templates/Alex.hs view
@@ -19,23 +19,24 @@ import Data.List -import Util.Dir-import Util.Path-import Util.List+import Bamse.Util.Dir+import System.FilePath import Bamse.Package import Bamse.PackageUtils +pkgName, pkgVersion, pkgDoc :: String pkgName = "alex"-pkgVersion = "2.01"-pkgDoc = "doc\\alex\\alex.html"+pkgVersion = "2.3.1"+pkgDoc = "doc\\alex-"++pkgVersion++"\\index.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package pkg = Package { name = pkgName , title = pkgName- , productVersion = "2.0.1.0"+ , productVersion = "2.3.1.0" , author = "Simon Marlow" , comment = unwords [pkgName, "Version", pkgVersion] }@@ -104,7 +105,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == "CVS")+ not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -134,4 +135,12 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = []++assemblies :: [Assembly]+assemblies = []+
templates/Bamse.hs view
@@ -20,14 +20,16 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir ( DirTree(..), findFiles )-import Util.Path ( baseName, dirname, fileSuffix )+import Bamse.Util.Dir ( DirTree, findFiles ) import Debug.Trace+import System.FilePath +pkgName, pkgVersion :: String pkgName = "bamse"-pkgVersion = "1.0"+pkgVersion = "1.2" -- what to output the MSI as if no -o option is given.+defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together.@@ -92,10 +94,10 @@ iconDir = lFile (toolDir ienv) "icons" desktopShortcuts :: InstallEnv -> [Shortcut]-desktopShortcuts ienv = []+desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ]-extensions ienv = []+extensions _ienv = [] verbs :: [ ( String -- extension , String -- verb@@ -120,21 +122,21 @@ ofInterest' f = if ofInterest f then trace ("including:" ++ f) True- else trace ("excluding:" ++ f ++ show (dirname f)) False+ else trace ("excluding:" ++ f ++ show (takeDirectory f)) False - ofInterest file = {-trace ("considering: " ++ show (dirname fileRel, fileRel)) $ -} not $+ ofInterest file = {-trace ("considering: " ++ show (takeDirectory fileRel, fileRel)) $ -} not $ emacsCVSMeta fileRel || fileRel `elem` [ ".cvsignore", "TODO" ] || fileRel `elem` ["out", "output", "packages", "libraries", "soe"] ||- (dirname fileRel == "." && fileSuffix fileRel == "log") ||- (dirname fileRel == "." && fileSuffix fileRel == "msi") ||- (dirname fileRel == "." && fileSuffix fileRel == "exe") ||- (dirname fileRel == "." && fileSuffix fileRel == "a") ||- fileSuffix fileRel `elem` ["o", "obj", "hi"]+ (takeDirectory fileRel == "" && takeExtension fileRel == ".log") ||+ (takeDirectory fileRel == "" && takeExtension fileRel == ".msi") ||+ (takeDirectory fileRel == "" && takeExtension fileRel == ".exe") ||+ (takeDirectory fileRel == "" && takeExtension fileRel == ".a") ||+ takeExtension fileRel `elem` [".o", ".obj", ".hi"] where fileRel = dropDirPrefix (srcDir ienv) file emacsCVSMeta f = - case baseName f of+ case takeFileName f of '#':_ -> True '.':'#':_ -> True "CVS" -> True@@ -177,3 +179,9 @@ , ("galois.msi", Nothing) ] -}++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Base.hs view
@@ -41,14 +41,18 @@ , services -- :: [Service] , ghcPackageInfo -- :: Maybe GhcPackage , nestedInstalls -- :: [(String, Maybe String)]+ , cabalPackageInfo+ , assemblies ) where import Bamse.Package import Bamse.PackageUtils-import Util.Dir ( DirTree, GenDirTree(..) )+import Bamse.Util.Dir ( DirTree, GenDirTree(..) ) +appName :: String appName = "myapp" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName appName pkg :: Package@@ -85,10 +89,10 @@ startMenu _ienv = (baseFeatureName, []) desktopShortcuts :: InstallEnv -> [Shortcut]-desktopShortcuts ienv = []+desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ]-extensions ienv = [ ]+extensions _ienv = [ ] verbs :: [ ( String -- extension , String -- verb@@ -108,7 +112,7 @@ featureMap = Nothing license :: InstallEnv -> Maybe FilePath-license ienv = Nothing+license _ienv = Nothing userRegistration :: Bool userRegistration = False@@ -128,4 +132,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++nestedInstalls :: [a] nestedInstalls = []++assemblies :: [Assembly]+assemblies = []
templates/ComPkg.hs view
@@ -17,15 +17,21 @@ -------------------------------------------------------------------- module ComPkg where -import Util.Dir-import Util.Path+import Bamse.Util.Dir+import System.FilePath import Bamse.Package import Bamse.PackageUtils import Debug.Trace +versionNumber :: String versionNumber = "0.30"+libVersion :: String libVersion = "comlib-" ++ versionNumber++defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion++packageName :: String packageName="comLib" pkg :: Package@@ -94,23 +100,23 @@ ofInterest' f = if ofInterest f then trace ("including:" ++ f) True- else trace ("excluding:" ++ f ++ show (dirname f)) False+ else trace ("excluding:" ++ f ++ show (takeDirectory f)) False -- Note: 'path' is prefixed by 'topDir'. ofInterest path = path == srcDir ienv -- || ("System" `elem` splitPath path && not ("tmp" `elem` splitPath path))- || baseName path `elem` ["com.pkg", "HScom.o", "doc", "include", "cbits"]- || baseName path == "doc" || baseName (dirname path) == "doc"- || baseName path == "build" || baseName (dirname path) == "build"- || fileSuffix path `elem` [{-"",-} "a", "hi", "h", "hs"]- || not (emacsCVSMeta path || fileSuffix path `elem` ["raw-hs"])+ || takeFileName path `elem` ["com.pkg", "HScom.o", "doc", "include", "cbits"]+ || takeFileName path == "doc" || takeFileName (takeDirectory path) == "doc"+ || takeFileName path == "build" || takeFileName (takeDirectory path) == "build"+ || takeExtension path `elem` [{-"",-} ".a", ".hi", ".h", ".hs"]+ || not (emacsCVSMeta path || takeExtension path `elem` [".raw-hs"]) -- By leaving out "", we won't recurse into subdirs. We specially -- check for the toplevel directory, as it needs to be present.--- (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h", "pkg"])+-- (takeExtension file `elem` [""{-directory-}, ".dll", ".hs", ".lhs", ".idl", ".h", ".pkg"]) emacsCVSMeta f = - case baseName f of+ case takeFileName f of '#':_ -> True '.':'#':_ -> True "CVS" -> True@@ -162,4 +168,12 @@ def s v = '-':'D':s ++ '=':tgt v +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []+++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Cryptol.hs view
@@ -20,14 +20,16 @@ import Bamse.Package import Bamse.PackageUtils -import Util.Dir ( DirTree(..), findFiles )-import Util.Path ( baseName )-import Util.List ( concatWith )+import Bamse.Util.Dir ( DirTree, findFiles )+import Bamse.Util.List ( concatWith )+import System.FilePath +pkgName, pkgVersion :: String pkgName = "Cryptol" pkgVersion = expandString "$<VERSION:1.5>" -- what to output the MSI as if no -o option is given.+defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together.@@ -80,6 +82,7 @@ sepBy ch ls = concatWith ch ls tgt = ("[TARGETDIR]"++) +cryptolSettings :: [RegEntry] cryptolSettings = -- ToDo: have the interpreter create these entries on-the-fly, if missing. -- => drop these entries.@@ -141,14 +144,14 @@ ] cryptolExtension :: FilePath -> FilePath -> String -> Extension-cryptolExtension topDir toolDir ext +cryptolExtension topDir tDir ext = ( "CryptolFile" , lFile topDir "cryptol.exe" , lFile iconDir "cry.exe" , ext ) where- iconDir = lFile toolDir "icons"+ iconDir = lFile tDir "icons" verbs :: [ ( String -- extension , String -- verb@@ -176,8 +179,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == "CVS") &&- not (baseName file == "bin")+ not (takeFileName file == "CVS") &&+ not (takeFileName file == "bin") {- Older experiment in specifying a dist tree which differed from the source tree. Keep around as it might prove useful@@ -263,4 +266,12 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = []++assemblies :: [Assembly]+assemblies = []+
templates/GHC.hs view
@@ -21,19 +21,26 @@ -------------------------------------------------------------------- module GHC where -import Util.Dir-import Util.Path+import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils+import System.FilePath -- Start section of version-specific settings:+versionNumber :: String versionNumber = "6.6.1"++versionStringUser :: String versionStringUser = "version " ++ versionNumber+buildNumber :: String buildNumber = "0"++ghcVersion :: String ghcVersion = "ghc-" ++ versionNumber -- End section -- default name of output file; used if no -o option is provided.+defaultOutFile :: FilePath defaultOutFile = toMsiFileName ghcVersion -- @@ -140,7 +147,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (not (null (tail file)) && last file == '~') &&- not (baseName file == "CVS")+ not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -171,4 +178,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/GaloisPkg.hs view
@@ -17,17 +17,21 @@ -------------------------------------------------------------------- module GaloisPkg where -import Util.Dir-import Util.Path+import Bamse.Util.Dir+import System.FilePath import Bamse.Package import Bamse.PackageUtils-import Debug.Trace import Data.Maybe ( fromJust ) +versionNumber :: String versionNumber = "0.10"+libName :: String libName="galois"++libVersion :: String libVersion = "galois-" ++ versionNumber +defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion pkg :: Package@@ -79,10 +83,10 @@ iconDir = toolDir ienv ++ "\\icons" desktopShortcuts :: InstallEnv -> [Shortcut]-desktopShortcuts ienv = []+desktopShortcuts _ienv = [] extensions :: InstallEnv -> [ Extension ]-extensions ienv = [ ]+extensions _ienv = [ ] verbs :: [ ( String -- extension , String -- verb@@ -96,33 +100,35 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where -- Note: 'path' is prefixed by 'topDir'.- ofInterest path = True+ ofInterest _path = True {- = path == topDir - || baseName path `elem` ["com.pkg", "HScom.o", "doc", "imports", "include"]- || baseName path == "doc" || baseName (dirname path) == "doc"- || fileSuffix path `elem` [{-"",-} "a", "hi", "h"]+ || takeFileName path `elem` ["com.pkg", "HScom.o", "doc", "imports", "include"]+ || takeFileName path == "doc" || takeFileName (takeDirectory path) == "doc"+ || takeExtension path `elem` [{-"",-} ".a", ".hi", ".h"] -- By leaving out "", we won't recurse into subdirs. We specially -- check for the toplevel directory, as it needs to be present.--- (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h", "pkg"])+-- (takeExtension file `elem` [""{-directory-}, ".dll", ".hs", ".lhs", ".idl", ".h", ".pkg"]) -} distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing -- Just ( \ f -> Just (toDist f))+{- where -- Note: 'fn' does not have 'topDir' prepended to it. toDist fn | isHiFile fn = lFile "imports" fn -- store interface files in the imports/ directory, | isDocFile fn = lFile "doc" fn -- doc/html files in doc/ directory, | isHeaderFile fn = lFile "include" fn -- header files in include/, - | otherwise = baseName fn -- and everything else in the toplevel directory.+ | otherwise = takeFileName fn -- and everything else in the toplevel directory.+-} featureMap :: Maybe (FilePath -> FeatureName) featureMap = Nothing license :: InstallEnv -> Maybe FilePath-license ienv = Nothing+license _ienv = Nothing userRegistration :: Bool userRegistration = False@@ -155,5 +161,11 @@ def s v = '-':'D':s ++ '=':tgt v +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = [] +cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Greencard.hs view
@@ -17,14 +17,19 @@ -------------------------------------------------------------------- module Greencard where -import Util.Dir-import Util.Path+import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils -gcVersion = "gc-2.05"+import System.FilePath++gcVersion :: String+gcVersion = "gc-"++versionNumber++versionNumber :: String versionNumber = "2.05" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName gcVersion pkg :: Package@@ -99,15 +104,15 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == gcVersion) &&- not (baseName file == "green-card.junk") &&- not (baseName file == "distrib") &&- not (baseName file == "CVS") &&- not (baseName file == "mk") &&- (not (fileSuffix file == "o") ||- (baseName file == "HSgreencard.o")) &&- (not (fileSuffix file == "hi") ||- (baseName file == "StdDIS.hi"))+ not (takeFileName file == gcVersion) &&+ not (takeFileName file == "green-card.junk") &&+ not (takeFileName file == "distrib") &&+ not (takeFileName file == "CVS") &&+ not (takeFileName file == "mk") &&+ (not (takeExtension file == ".o") ||+ (takeFileName file == "HSgreencard.o")) &&+ (not (takeExtension file == ".hi") ||+ (takeFileName file == "StdDIS.hi")) distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -136,4 +141,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/HDirectLib.hs view
@@ -17,14 +17,18 @@ -------------------------------------------------------------------- module HDirectLib where -import Util.Dir-import Util.Path+import Bamse.Util.Dir+import System.FilePath import Bamse.Package import Bamse.PackageUtils +libVersion :: String libVersion = "hdirect-lib-0.19-hugsDec2001"++versionNumber :: String versionNumber = "0.19" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName libVersion pkg :: Package@@ -80,7 +84,7 @@ where -- Note: the file is also the name of the directory ofInterest file = - (fileSuffix file `elem` [""{-directory-}, "dll", "hs", "lhs", "idl", "h"])+ (takeExtension file `elem` [""{-directory-}, ".dll", ".hs", ".lhs", ".idl", ".h"]) distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -109,4 +113,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Haddock.hs view
@@ -18,17 +18,19 @@ module Haddock where import Data.List+import System.FilePath -import Util.Dir-import Util.Path-import Util.List+import Bamse.Util.Dir import Bamse.Package import Bamse.PackageUtils ++pkgName, pkgVersion, pkgDoc :: String pkgName = "haddock" pkgVersion = "0.7" pkgDoc = "doc\\haddock\\haddock.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package@@ -104,7 +106,7 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == "CVS")+ not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -134,4 +136,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Happy.hs view
@@ -19,23 +19,26 @@ import Data.List -import Util.Dir-import Util.Path-import Util.List+import Bamse.Util.Dir+import System.FilePath import Bamse.Package import Bamse.PackageUtils +pkgName :: String pkgName = "happy"-pkgVersion = "1.15"-pkgDoc = "doc\\happy\\index.html"+pkgVersion :: String+pkgVersion = "1.18.3"+pkgDoc :: String+pkgDoc = "doc\\happy-"++pkgVersion++"\\index.html" +defaultOutFile :: FilePath defaultOutFile = toMsiFileName pkgName pkg :: Package pkg = Package { name = pkgName , title = pkgName- , productVersion = "1.1.5.0"+ , productVersion = "1.18.3.0" , author = "Simon Marlow" , comment = unwords [pkgName, "Version", pkgVersion] }@@ -104,8 +107,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == "CVS")- + not (takeFileName file == "CVS")+ distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing @@ -134,4 +137,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++nestedInstalls :: [(FilePath, Maybe String)] nestedInstalls = []++assemblies :: [Assembly]+assemblies = []
+ templates/HsDotnet.hs view
@@ -0,0 +1,175 @@+--------------------------------------------------------------------+-- |+-- Module : HsDotnet+-- Description : Specification/template for the hs-dotnet package.+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@forkIO.com>+-- Stability : provisional+-- Portability : portable+--+-- To create your own installer, you need to supply a Haskell module+-- which exports functions and values that together define the+-- functionality (and contents) of your package;+-- see Base.hs just what those exports are.+--+--------------------------------------------------------------------+module HsDotnet where++import Bamse.Package+import Bamse.PackageUtils++versionNumber :: String+versionNumber = "0.40"++libVersion :: String+libVersion = "hs-dotnet-" ++ versionNumber++defaultOutFile :: FilePath+defaultOutFile = toMsiFileName libVersion++packageName :: String+packageName="hs-dotnet"++pkg :: Package+pkg = Package+ { name = "hs-dotnet"+ , title = "Haskell .NET interop framework"+ , productVersion = "1.0.4.0"+ , author = "Sigbjorn Finne"+ , comment = "Version: " ++ versionNumber+ }++webSite :: String+webSite = "http://haskell.forkio.com/hs-dotnet"++bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "art/banner.bmp")++bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap _ienv = Nothing++registry :: [RegEntry]+registry = []++features :: [Tree Feature]+features = [ Leaf baseFeature ]++baseFeatureName :: String+baseFeatureName = "hsdotnet"++baseFeature :: Feature+baseFeature = (baseFeatureName, "hs-dotnet package for GHC")++startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("Haskell/"++packageName, entries)+ where+ entries :: [Shortcut]+ entries = + [ Shortcut "Documentation (HTML)"+ (lFile (srcDir ienv) "dist\\doc\\html\\hs-dotnet\\index.html")+ ""+ "Library documentation"+ (Just (lFile iconDir "html.exe"))+ 1+ "[TARGETDIR]"+ ]++ iconDir = toolDir ienv ++ "\\icons"++desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = []++extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [ ]++verbs :: [ ( String -- extension+ , String -- verb+ , String -- label+ , String -- arguments+ )+ ]+verbs = []++dirTree :: InstallEnv -> IO DirTree+dirTree ienv = do+ mf <- getManifest (userOpts ienv)+ findFiles (entryOfInterest ienv mf) topDir+ where+ topDir = srcDir ienv ++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing++userRegistration :: Bool+userRegistration = False++defaultInstallFolder :: Maybe String+defaultInstallFolder = Just $ "[WindowsVolume]ghc\\packages\\ghc-"++forGhcVersion ++ "\\" ++ packageName ++ "\\"++forGhcVersion :: String+forGhcVersion = "6.10.1"++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = False++services :: [Service]+services = []++nestedInstalls :: [a]+nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Just $+ CabalPackage { cabal_packageName = "hs-dotnet"+ -- ToDo: allow 'most-recent' compiler to be used.+ , cabal_forGhcVersion = forGhcVersion+ , cabal_packageFile = Just "hs-dotnet.cabal"+ , cabal_pkgCmdLine = Nothing+ , cabal_fromSource = True+ }++assemblies :: [Assembly]+assemblies = [ bridge_assembly ]++-- don't like the duplication of information here (version magic number in installer, bridge and package..!)+-- Ditto for the public key..absolutely mental.+bridge_assembly :: Assembly+bridge_assembly = + emptyAssembly+ { assem_dll = "HsDotnetBridge.dll"+ , assem_name = "HsDotnetBridge"+ , assem_manifest = Just "HsDotnetBridge.dll"+ , assem_version = "0.4.0.0"+ , assem_publicKey = "31b6626774fafd8b"+ , assem_win32 = False -- the default, but still.+ }++--- unused stuff until the end:++{- OLD and incomplete support for GHC .pkgs:+ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Just $+ GhcPackage { ghc_packageName = "hs-dotnet"+ -- ToDo: allow 'most-recent' compiler to be used.+ , ghc_forVersion = forGhcVersion+ , ghc_packageFile = Just "hs-dotnet.cabal"+ , ghc_pkgCmdLine = Just (unwords [ "Setup", "install" ])+ }+ where+ tgt "" = "\"[TARGETDIR]build\""+ tgt s = "\"[TARGETDIR]" ++ s ++ "\""+ + def s v = '-':'D':s ++ '=':tgt v+-}+
templates/Hugs98.hs view
@@ -19,12 +19,14 @@ import Bamse.Package import Bamse.PackageUtils-import Util.Dir-import Util.Path+import Bamse.Util.Dir+import System.FilePath +hugsVersion, versionString :: String hugsVersion = "Nov 2003" versionString = "Nov2003" +defaultOutFile :: String defaultOutFile = toMsiFileName "hugs98-Nov2003" pkg :: Package@@ -193,7 +195,7 @@ ofInterest file = not (ignoreDir file) && not (last file == '~') &&- not (baseName file == "CVS")+ not (takeFileName file == "CVS") ignoreDir file = file `elem` ignore_dirs @@ -232,4 +234,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/Hugs98Net.hs view
@@ -21,12 +21,16 @@ import Bamse.Package import Bamse.PackageUtils-import Util.Dir-import Util.Path+import Bamse.Util.Dir+import System.FilePath +versionNumber :: String versionNumber = "March2003" +defaultOutFile :: FilePath defaultOutFile = "hugs98-net-March2003.msi"++packageDir :: String packageDir = "hugs98-net" @@ -125,7 +129,7 @@ file /= topDir ++ "\\demos" && file /= topDir ++ "\\tools" && not (last file == '~') &&- not (baseName file == "CVS")+ not (takeFileName file == "CVS") distFileMap :: Maybe (FilePath -> Maybe FilePath) distFileMap = Nothing@@ -154,4 +158,13 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing ++nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []+
templates/PubCryptol.hs view
@@ -22,15 +22,17 @@ import Bamse.Package import Bamse.PackageUtils -import Data.List ( intersperse )-import Util.Dir ( DirTree(..), findFiles )-import Util.Path ( baseName )-import Util.List ( concatWith )+import Bamse.Util.Dir ( DirTree, findFiles )+import Bamse.Util.List ( concatWith )+import System.FilePath +pkgName :: String pkgName = "Cryptol"+pkgVersion :: String pkgVersion = "0.1" -- expandString "$<VERSION:1.4.2pre2>" -- what to output the MSI as if no -o option is given.+defaultOutFile :: FilePath defaultOutFile = toMsiFileName (pkgName ++ '-':pkgVersion) -- 'information summary stream' data bundled up together.@@ -83,6 +85,7 @@ sepBy ch ls = concatWith ch ls tgt = ("[TARGETDIR]"++) +cryptolSettings :: [RegEntry] cryptolSettings = -- ToDo: have the interpreter create these entries on-the-fly, if missing. -- => drop these entries.@@ -134,14 +137,14 @@ ] cryptolExtension :: FilePath -> FilePath -> String -> Extension-cryptolExtension topDir toolDir ext +cryptolExtension topDir tDir ext = ( "CryptolFile" , lFile topDir "cryptol.exe" , lFile iconDir "cry.exe" , ext ) where- iconDir = lFile toolDir "icons"+ iconDir = lFile tDir "icons" verbs :: [ ( String -- extension , String -- verb@@ -169,8 +172,8 @@ dirTree ienv = findFiles ofInterest (srcDir ienv) where ofInterest file = not (last file == '~') &&- not (baseName file == "CVS") &&- not (baseName file == "bin")+ not (takeFileName file == "CVS") &&+ not (takeFileName file == "bin") {- Older experiment in specifying a dist tree which differed from the source tree. Keep around as it might prove useful@@ -226,7 +229,7 @@ topDir = srcDir ++ "\\cryptol" ofInterest file = let- base = baseName file+ base = takeFileName file suf = fileSuffix file in not (last file `elem` "~#") && not (base == "CVS") &&@@ -256,4 +259,11 @@ ghcPackageInfo :: Maybe GhcPackage ghcPackageInfo = Nothing +nestedInstalls :: [(FilePath,Maybe String)] nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
templates/SOE.hs view
@@ -19,12 +19,12 @@ -------------------------------------------------------------------- module SOE where -import MSIExtra-import Util.Dir-import Package+import Bamse.Util.Dir+import Bamse.Package+import Bamse.PackageUtils +defaultOutFile :: FilePath defaultOutFile = "SOE.msi"-srcDir = "c:\\src" pkg :: Package pkg = Package@@ -33,64 +33,50 @@ , productVersion = "1.0.0.0" , author = "Paul Hudak" , comment = "Software accompanying textbook"- , date = pkg_date- , revisionGUID = "{07a7cf12-5509-45d3-92d3-826b95dde09f}"- , packageGUID = "{79a39c17-1723-437f-a415-b7ca566fa96b}"- , creationTime = pkg_date }- where- pkg_date = "13/01/2002 23:00:00" webSite :: String webSite = "http://haskell.org/soe" -bannerBitmap :: Maybe FilePath-bannerBitmap = Just "c:/src/bamse/soe/banner.bmp"+bannerBitmap :: InstallEnv -> Maybe FilePath+bannerBitmap ienv = Just (lFile (toolDir ienv) "soe/banner.bmp") +bgroundBitmap :: InstallEnv -> Maybe FilePath+bgroundBitmap ienv = Just (lFile (toolDir ienv) "art/bground2.bmp")+ registry :: [RegEntry] registry = haskellProject "SOE" [ hugsPath "[TARGETDIR]src;[TARGETDIR]graphics\\lib\\win32;[TARGETDIR]haskore\\src" ] -hugsPath val = ("hugsPath", val)--haskellProject nm values- = RegEntry "HKLM" "Software" (CreateKey False) :- RegEntry "HKLM" "Software\\Haskell" (CreateKey False) :- RegEntry "HKLM" "Software\\Haskell\\Projects" (CreateKey False) :- RegEntry "HKLM" proj_path (CreateKey True) :- map (\ (nm,val) -> RegEntry "HKLM" proj_path- (CreateName (Just nm) val))- values- where- proj_path = "Software\\Haskell\\Projects\\"++nm--features :: [(String, String)]-features = [ baseFeature ]+features :: [Tree Feature]+features = [ Leaf baseFeature ] -baseFeature :: (String, String)+baseFeature :: Feature baseFeature = ("SOE", "School of Expression") -startMenu :: (String, [Shortcut])-startMenu = ("School of Expression", entries)+startMenu :: InstallEnv -> (String, [Shortcut])+startMenu ienv = ("School of Expression", entries) where+ iconDir = lFile (toolDir ienv) "icons"+ entries :: [Shortcut] entries = [ Shortcut "Source code"- "c:\\src\\soelib\\src\\Code.html"+ (lFile (srcDir ienv) "src\\Code.html") "" "Example code"- (Just ("c:\\src\\bamse\\soe\\html.exe"))+ (Just (lFile iconDir "html.exe")) 1 "[TARGETDIR]src" ] -desktopShortcuts :: [Shortcut]-desktopShortcuts = []+desktopShortcuts :: InstallEnv -> [Shortcut]+desktopShortcuts _ienv = [] -extensions :: [ Extension ]-extensions = []+extensions :: InstallEnv -> [ Extension ]+extensions _ienv = [] verbs :: [ ( String -- extension , String -- verb@@ -100,19 +86,50 @@ ] verbs = [] -dirTrees :: IO [DirTree]-dirTrees = do - fs <- findFiles ofInterest (srcDir ++ "\\soelib")- return [fs]+dirTree :: InstallEnv -> IO DirTree+dirTree ienv = do + fs <- findFiles ofInterest (srcDir ienv ++ "\\soelib")+ return fs where ofInterest file = not (last file == '~') -license :: Maybe FilePath-license = Nothing -- Just "c:\\src\\soelib\\license.rtf"+license :: InstallEnv -> Maybe FilePath+license _ienv = Nothing -- Just "c:\\src\\soelib\\license.rtf" userRegistration :: Bool userRegistration = False defaultInstallFolder :: Maybe String defaultInstallFolder = Nothing+++distFileMap :: Maybe (FilePath -> Maybe FilePath)+distFileMap = Nothing++-- if provided, a mapping from dist tree filename to the+-- the feature it belongs to. If Nothing, all files are+-- mapped to the base feature.+featureMap :: Maybe (FilePath -> FeatureName)+featureMap = Nothing++finalMessage :: Maybe String+finalMessage = Nothing++userInstall :: Bool+userInstall = True++services :: [Service]+services = []++ghcPackageInfo :: Maybe GhcPackage+ghcPackageInfo = Nothing++nestedInstalls :: [(FilePath,Maybe String)]+nestedInstalls = []++cabalPackageInfo :: Maybe CabalPackage+cabalPackageInfo = Nothing++assemblies :: [Assembly]+assemblies = []
+ tests/Tests.hs view
@@ -0,0 +1,37 @@+module Main where + +import Bamse.Util.List +import Test.QuickCheck +import Test.HUnit + +instance Arbitrary Char where + arbitrary = choose ('\x20','\x80') + coarbitrary c = variant (fromEnum c `mod` 4) + +unitSplit :: Test +unitSplit = TestList $ + zipWith (\ t i -> ("Bamse.Util.List.split-"++show i) ~: t) + [ ["a","b","c"] ~=? (split ',' "a,b,c") + , ["a","b","c"] ~=? (split ',' "a,b,c,") + ] + [(1::Integer)..] + +unitList :: Test +unitList = TestList + [ unitSplit + ] + +quickList :: IO () +quickList = do + quickCheck (\ s -> null s == null (init0 s) || init0 (s::String) == take (length s - 1) s) + +checkList :: IO () +checkList = do + quickList + c <- runTestTT unitList + putStrLn (showCounts c) + +main :: IO () +main = do + checkList +
+ tools/Wrapper.hs view
@@ -0,0 +1,17 @@+module Main(main) where + +import System.Cmd +import System.Environment +import System.Directory +import System.Exit + +main :: IO () +main = do + ls <- getArgs + case ls of + (c:a:xs) -> do + setCurrentDirectory c + ex <- rawSystem a xs + exitWith ex + +
+ tools/custWrap.exe view
binary file changed (absent → 883212 bytes)
tools/msiIcon.c view
@@ -168,7 +168,7 @@ // It's an .ico file; copy it. return CopyFileW(dllName, fName, FALSE); }- fwprintf(stderr, L"WriteIcon: Couldn't load '%s'\n", dllName);+ fprintf(stderr, "WriteIcon: Couldn't load '%s'\n", dllName); return FALSE; }