packages feed

MicroCabal 0.1.0.0 → 0.2.0.0

raw patch · 13 files changed

+509/−219 lines, 13 filesdep ~basedep ~directorydep ~process

Dependency ranges changed: base, directory, process

Files

Makefile view
@@ -12,7 +12,7 @@ all:	bin/gmcabal bin/mcabal  clean:-	rm -rf ghc-out bin/*+	rm -rf ghc-out bin/* .mhscache 	cabal clean  test:	bin/mcabal@@ -21,3 +21,7 @@ 	bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/polyparse-1.12/polyparse.cabal 	bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/cpphs-1.20.9/cpphs.cabal 	bin/mcabal parse ../Hackage/optparse-applicative-0.18.1.0/optparse-applicative.cabal++install: bin/mcabal+	@mkdir -p ~/.mcabal/bin+	cp bin/mcabal ~/.mcabal/bin
MicroCabal.cabal view
@@ -1,7 +1,7 @@ cabal-version:         3.0 name:                  MicroCabal-version:               0.1.0.0-synopsis:              A Cabal replacement+version:               0.2.0.0+synopsis:              A partial Cabal replacement license:               Apache-2.0 license-file:          LICENSE copyright:             2024 Lennart Augustsson@@ -13,20 +13,20 @@ build-type:            Simple  extra-source-files:-  LICENSE-  Makefile-  README.md+                       LICENSE+                       Makefile+                       README.md  source-repository head   type:                git   location:            https://github.com/augustss/MicroCabal  executable mcabal-  default-language:    Haskell2010+  default-language:    Haskell98   hs-source-dirs:      src   ghc-options:         -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -main-is MicroCabal.Main   main-is:             MicroCabal/Main.hs-  default-extensions:  ScopedTypeVariables MultiParamTypeClasses+  default-extensions:  MultiParamTypeClasses   other-modules:       MicroCabal.Backend.GHC                        MicroCabal.Backend.MHS                        MicroCabal.Cabal@@ -37,6 +37,6 @@                        MicroCabal.Unix                        MicroCabal.YAML                        Text.ParserComb-  build-depends:       base         >= 4.10 && < 4.20,-                       directory    >= 1.3 && < 1.5,-                       process      >= 1.6 && < 1.8,+  build-depends:       base         >= 4.10 && < 4.25,+                       directory    >= 1.3 && < 1.6,+                       process      >= 1.6 && < 1.9,
README.md view
@@ -7,3 +7,5 @@  The implementation assumes a Unix-like system with commands like `wget` and `tar`. +To get a consistent set of packages MicroCabal uses Stackage to find compatible packages. So in a sense, MicroCabal is more like a MicroStackage. +
src/MicroCabal/Backend/GHC.hs view
@@ -1,14 +1,16 @@ module MicroCabal.Backend.GHC(ghcBackend) where import Control.Monad+import Data.List import Data.Version import System.Directory import MicroCabal.Cabal import MicroCabal.Env+import MicroCabal.Parse(readVersion) import MicroCabal.Unix  ghcBackend :: Backend ghcBackend = Backend {-  backendName = "ghc",+  backendNameVers = ghcNameVers,   doesPkgExist = ghcExists,   buildPkgExe = ghcBuildExe,   buildPkgLib = ghcBuildLib,@@ -16,30 +18,48 @@   installPkgLib = ghcInstallLib   } +ghcNameVers :: Env -> IO (String, Version)+ghcNameVers env = do+  svers <- takeWhile (/= '\n') <$> cmdOut env "ghc --numeric-version"+  -- Check that the ghc version is the one that the Stackage snapshot wants.+  -- XXX This should be somewhere else.+  snapVersion <- readFile (cabalDir env </> "ghc-version")+  let ghcVersion = "ghc-" ++ svers+  when (snapVersion /= ghcVersion) $+    error $ "The Stackage snapshot files are for " ++ snapVersion ++ ", but the current compiler is " ++ ghcVersion+  return ("ghc", readVersion svers)+ getGhcName :: Env -> IO FilePath-getGhcName env = ("ghc-" ++) . takeWhile (/= '\n') <$> cmdOut env "ghc --numeric-version"+getGhcName env = do+  (n, v) <- ghcNameVers env+  return $ n ++ "-" ++ showVersion v  getGhcDir :: Env -> IO FilePath-getGhcDir env = ((cabalDir env ++ "/") ++) <$> getGhcName env+getGhcDir env = (cabalDir env </>) <$> getGhcName env  getBuildDir :: Env -> IO FilePath getBuildDir env = do   ghc <- getGhcName env-  return $ distDir env ++ "/build/" ++ ghc+  return $ distDir env </> "build" </> ghc  initDB :: Env -> IO () initDB env = do   dir <- getGhcDir env   b <- doesDirectoryExist dir   when (not b) $ do-    when (verbose env > 0) $-      putStrLn $ "Creating GHC package db " ++ dir+    message env 0 $ "Creating GHC package db " ++ dir     cmd env $ "ghc-pkg init " ++ dir  ghcExists :: Env -> PackageName -> IO Bool ghcExists env pkgname = do-  dir <- getGhcDir env-  tryCmd env $ "ghc-pkg --package-db=" ++ dir ++ " describe >/dev/null 2>/dev/null " ++ pkgname+  -- First try with globally installed GHC packages.+  ok <- tryCmd env $ "ghc-pkg describe >/dev/null 2>/dev/null " ++ pkgname+  if ok then+    return True+   else do+    -- Try with packages installed wikh mcabal+    dir <- getGhcDir env+    tryCmd env $ "ghc-pkg --package-db=" ++ dir ++ " describe >/dev/null 2>/dev/null " ++ pkgname  setupStdArgs :: Env -> [Field] -> IO [String] setupStdArgs env flds = do@@ -49,86 +69,117 @@       exts    = getFieldStrings flds defExts "extensions"       opts    = getFieldStrings flds []      "ghc-options"       cppOpts = getFieldStrings flds []      "cpp-options"+      incDirs = getFieldStrings flds []      "include-dirs"+      mlang   = getFieldStringM flds         "default-language"       deps    = getBuildDependsPkg flds+      lang    = maybe [] (\ s -> ["-X" ++ s]) mlang   buildDir <- getBuildDir env   return $ [ "-package-env=-", "-package-db=" ++ db, "-outputdir=" ++ buildDir, "-w"] ++            map ("-i" ++) srcDirs +++           ["-i" ++ pathModuleDir] +++           map ("-I" ++) incDirs ++            map ("-X" ++) exts +++           lang ++            map ("-package " ++) deps ++            opts ++ cppOpts -binGhc :: String-binGhc  = "/bin/ghc/"+binGhc :: FilePath+binGhc  = "bin" </> "ghc"  ghcBuildExe :: Env -> Section -> Section -> IO () ghcBuildExe env _ (Section _ name flds) = do   initDB env   let mainIs  = getFieldString flds "main-is"       srcDirs = getFieldStrings flds ["."] "hs-source-dirs"-      bin     = distDir env ++ binGhc ++ name-  mkdir env $ distDir env ++ binGhc+      bin     = distDir env </> binGhc </> name+  mkdir env $ distDir env </> binGhc   mainIs' <- findMainIs env srcDirs mainIs   stdArgs <- setupStdArgs env flds-  let args    = unwords $ ["-O"] ++ stdArgs ++ ["-o", bin, "--make", mainIs']-  when (verbose env >= 0) $-    putStrLn $ "Build executable " ++ bin ++ " with ghc"+  let args    = unwords $ ["-O"] ++ stdArgs ++ ["-o", bin, "--make", mainIs'] +++                [ ">/dev/null" | verbose env <= 0 ]+  message env 0 $ "Building executable " ++ bin ++ " with ghc"   cmd env $ "ghc " ++ args  findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath findMainIs _ [] fn = error $ "cannot find " ++ show fn findMainIs env (d:ds) fn = do-  let fn' = d ++ "/" ++ fn+  let fn' = d </> fn   b <- doesFileExist fn'   if b then     return fn'    else     findMainIs env ds fn +-- It can happen that there are no exposed modules.+-- E.g., for a package only needed for certain versions. getExposedModules :: [Field] -> [String]-getExposedModules flds = getFieldStrings flds (error "no exposed-modules") "exposed-modules"+getExposedModules flds = getFieldStrings flds [] "exposed-modules" +getOtherModules :: [Field] -> [String]+getOtherModules flds = getFieldStrings flds [] "other-modules"+ ghcBuildLib :: Env -> Section -> Section -> IO () ghcBuildLib env (Section _ _ glob) (Section _ name flds) = do   initDB env   stdArgs <- setupStdArgs env flds-  let mdls = getExposedModules flds+  let emdls = getExposedModules flds+      omdls = getOtherModules flds+      mdls = emdls ++ omdls       ver  = getVersion glob "version"       args = unwords $ ["-O"] ++ stdArgs ++                        ["--make", "-no-link", "-this-unit-id", key ] ++                        ["-fbuilding-cabal-package", "-static" ] ++-                       mdls+                       mdls +++                       [ ">/dev/null" | verbose env <= 0 ]       key = name ++ "-" ++ showVersion ver ++ "-mcabal"-  when (verbose env >= 0) $-    putStrLn $ "Build library " ++ name ++ " with ghc"-  cmd env $ "ghc " ++ args+  if null mdls then+    message env 0 $ "Building library " ++ name ++ " with ghc skipped, no modules"+   else do+    message env 0 $ "Building library " ++ name ++ " with ghc"+    cmd env $ "ghc " ++ args  ghcInstallExe :: Env -> Section -> Section -> IO () ghcInstallExe env (Section _ _ _glob) (Section _ name _) = do   let bin = distDir env ++ binGhc ++ name-      binDir = cabalDir env ++ "/bin"+      binDir = cabalDir env </> "bin"   mkdir env binDir-  cp env bin (binDir ++ "/" ++ name)+  cp env bin (binDir </> name) +getPackageId :: Env -> PackageName -> IO PackageName+getPackageId env n = do+  mr <- tryCmdOut env $ "ghc-pkg field " ++ n ++ " id 2>/dev/null"  -- returns "id: pkg-id"+  case mr of+    Just r -> return $ last $ words r+    Nothing -> do+      dir <- getGhcDir env+      last . words <$> cmdOut env ("ghc-pkg field  --package-db=" ++ dir ++ " " ++ n ++ " id")  -- returns "id: pkg-id"+ ghcInstallLib :: Env -> Section -> Section -> IO () ghcInstallLib env (Section _ _ glob) (Section _ name flds) = do   initDB env   buildDir <- getBuildDir env   ghc <- getGhcDir env   let namever = name ++ "-" ++ showVersion vers-      destDir = ghc ++ "/" ++ namever+      destDir = ghc </> namever       vers = getVersion glob "version"-      arch = destDir ++ "/" ++ "libHS" ++ namever ++ "-mcabal.a"+      archOut = destDir </> "libHS" ++ namever ++ "-mcabal.a"   mkdir env destDir-  rmrf env arch-  cmd env $ "ar -c -r -s " ++ arch ++ " `find " ++ buildDir ++ " -name '*.o'`"+  rmrf env archOut -  let files = map mdlToHi mdls+  let files = map mdlToHi (omdls ++ mdls)       mdls = getExposedModules flds+      omdls = getOtherModules flds       mdlToHi = (++ ".hi") . map (\ c -> if c == '.' then '/' else c)-  copyFiles env buildDir files destDir +  when (not (null files)) $ do+    cmd env $ "ar -c -r -s " ++ archOut ++ " `find " ++ buildDir ++ " -name '*.o'`"+    copyFiles env buildDir files destDir+   db <- getGhcDir env-  let desc = unlines+  let extraLibs = getFieldStrings flds [] "extra-libraries"+      deps = getBuildDependsPkg flds+  depends <- nub <$> mapM (getPackageId env) deps+  let desc = unlines $         [ "name: " ++ name         , "version: " ++ showVersion vers         , "visibility: public"@@ -139,11 +190,12 @@         , "import-dirs: " ++ destDir         , "library-dirs: " ++ destDir         , "library-dirs-static: " ++ destDir-        , "hs-libraries: HS" ++ key+        , "extra-libraries: " ++ unwords extraLibs         , "depends: " ++ unwords depends-        ]-      depends = []  -- XXX+        ] +++        [ "hs-libraries: HS" ++ key | not (null files) ]       key = namever ++ "-mcabal"-      pkgFn = db ++ "/" ++ key ++ ".conf"+      pkgFn = db </> key ++ ".conf"+      quiet = if verbose env > 0 then "" else " >/dev/null"   writeFile pkgFn desc-  cmd env $ "ghc-pkg update --package-db=" ++ db ++ " " ++ pkgFn+  cmd env $ "ghc-pkg update --package-db=" ++ db ++ " " ++ pkgFn ++ quiet
src/MicroCabal/Backend/MHS.hs view
@@ -1,13 +1,18 @@ module MicroCabal.Backend.MHS(mhsBackend) where import Control.Monad+import Data.List(dropWhileEnd, (\\))+import Data.Maybe(fromMaybe)+import Data.Version import System.Directory+import System.Environment(lookupEnv) import MicroCabal.Cabal import MicroCabal.Env+import MicroCabal.Parse(readVersion) import MicroCabal.Unix  mhsBackend :: Backend mhsBackend = Backend {-  backendName = "mhs",+  backendNameVers = mhsNameVers,   doesPkgExist = mhsExists,   buildPkgExe = mhsBuildExe,   buildPkgLib = mhsBuildLib,@@ -15,9 +20,15 @@   installPkgLib = mhsInstallLib   } --- XXX needs version info+mhsNameVers :: Env -> IO (String, Version)+mhsNameVers env = do+  v <- readVersion . takeWhile (/= '\n') <$> cmdOut env "mhs --numeric-version"+  return ("mhs", v)+ getMhsDir :: Env -> IO FilePath-getMhsDir env = return $ cabalDir env ++ "/mhs"+getMhsDir env = do+  (n, v) <- mhsNameVers env+  return $ cabalDir env ++ "/" ++ n ++ "-" ++ showVersion v  initDB :: Env -> IO () initDB env = do@@ -25,49 +36,71 @@   b <- doesDirectoryExist dir   when (not b) $ do     --cmd env $ "mhs-pkg init " ++ dir-    mkdir env dir+    mkdir env (dir </> "packages")  mhsExists :: Env -> PackageName -> IO Bool-mhsExists env _pkgname = do-  _dir <- getMhsDir env-  return False+mhsExists _ pkgname | pkgname `elem` builtinPackages = return True+mhsExists env pkgname = do+  initDB env+  dir <- getMhsDir env+  pkgs <- listDirectory $ dir </> "packages"+  return $ any ((== pkgname) . init . dropWhileEnd (/= '-')) pkgs +-- XXX These packages are part of mhs.+builtinPackages :: [String]+builtinPackages = ["array", "base", "deepseq", "directory", "process", "bytestring", "text", "fail", "time"]+ setupStdArgs :: Env -> [Field] -> [String] setupStdArgs _env flds =   let srcDirs = getFieldStrings flds ["."]   "hs-source-dirs"       defExts = getFieldStrings flds []      "default-extensions"       exts    = getFieldStrings flds defExts "extensions"+      oexts   = getFieldStrings flds []      "other-extensions"       opts    = getFieldStrings flds []      "mhs-options"       cppOpts = getFieldStrings flds []      "cpp-options"-      exts'   = filter (`elem` mhsX) exts+      incs    = getFieldStrings flds []      "include-dirs"+      exts'   = filter (`elem` mhsX) (exts ++ oexts)       mhsX    = ["CPP"]-  in  map ("-i" ++) srcDirs +++  in  -- ["-i"] +++      map ("-i" ++) srcDirs ++       map ("-X" ++) exts' +++      map ("-I" ++) incs ++       opts ++ cppOpts  binMhs :: String-binMhs  = "/bin/ghc/"+binMhs  = "bin" </> "mhs"  mhsBuildExe :: Env -> Section -> Section -> IO () mhsBuildExe env _ (Section _ name flds) = do   initDB env   let mainIs  = getFieldString  flds         "main-is"       srcDirs = getFieldStrings flds ["."]   "hs-source-dirs"-      bin     = distDir env ++ binMhs ++ name-  mkdir env $ distDir env ++ binMhs+      bin     = distDir env </> binMhs </> name+  mkdir env $ distDir env </> binMhs   mainIs' <- findMainIs env srcDirs mainIs   let args    = unwords $ setupStdArgs env flds ++-                          ["-o" ++ bin, mainIs']+                          ["-a."+                          ,"-o" ++ bin, mainIs']   when (verbose env >= 0) $     putStrLn $ "Build " ++ bin ++ " with mhs"   --putStrLn $ "mhs " ++ args-  cmd env $ "MHSDIR=/usr/local/lib/mhs " ++    -- temporary hack+  mhs env args++mhs :: Env -> String -> IO ()+mhs env args = do+  let flg = if verbose env == 1 then "-l " else if verbose env > 1 then "-v " else ""+  mhsDir <- fmap (fromMaybe "/usr/local/lib/mhs") (lookupEnv "MHSDIR")+  cmd env $ "MHSDIR=" ++ mhsDir ++ " mhs " ++ flg ++ args++mhsOut :: Env -> String -> IO String+mhsOut env args =+  cmdOut env $ "MHSDIR=/usr/local/lib/mhs " ++    -- temporary hack             "mhs " ++ args  findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath findMainIs _ [] fn = error $ "cannot find " ++ show fn findMainIs env (d:ds) fn = do-  let fn' = d ++ "/" ++ fn+  let fn' = d </> fn   b <- doesFileExist fn'   if b then     return fn'@@ -75,20 +108,33 @@     findMainIs env ds fn  mhsBuildLib :: Env -> Section -> Section -> IO ()-mhsBuildLib env _ (Section _ name flds) = do+mhsBuildLib env (Section _ _ glob) (Section _ name flds) = do   initDB env   let mdls = getFieldStrings flds (error "no exposed-modules") "exposed-modules"-      args = unwords $ ["-P" ++ name] ++-                       setupStdArgs env flds ++ mdls-  error $ "No mhsBuildLib\n" ++ show args+      omdls = getFieldStrings flds [] "other-modules"+      vers = getVersion glob "version"+      namever = name ++ "-" ++ showVersion vers+      pkgfn = namever ++ ".pkg"+      args = unwords $ ["-P" ++ namever, "-o" ++ pkgfn] +++                       setupStdArgs env flds +++                       ["-a."] +++                       mdls+  mhs env args+  pkgmdls <- lines <$> mhsOut env ("-L" ++ pkgfn)+  let bad = pkgmdls \\ (mdls ++ omdls)+  when (not (null bad)) $ do+    putStrLn "Warning: package modules not mentioned in exposed-modules nor other-modules"+    mapM_ putStrLn bad  mhsInstallExe :: Env -> Section -> Section -> IO () mhsInstallExe env (Section _ _ _glob) (Section _ name _) = do-  let bin = distDir env ++ binMhs ++ name-      binDir = cabalDir env ++ "/bin"-  cp env bin binDir+  let bin = distDir env </> binMhs </> name+      binDir = cabalDir env </> "bin"+  cp env bin (binDir </> name)  mhsInstallLib :: Env -> Section -> Section -> IO ()-mhsInstallLib env _glob _sect = do+mhsInstallLib env (Section _ _ glob) (Section _ name _) = do   initDB env-  undefined+  let vers = getVersion glob "version"+      namever = name ++ "-" ++ showVersion vers+  mhs env $ "-Q " ++ namever ++ ".pkg"
src/MicroCabal/Cabal.hs view
@@ -12,11 +12,14 @@   FlagInfo(..),   showCabal, showSection,   getFieldString,+  getFieldStringM,   getFieldStrings,   getBuildDepends,   getBuildDependsPkg,   getVersion,+  pathModuleDir,   ) where+import Data.Maybe import Data.Version  --type ExecName = String@@ -33,6 +36,7 @@   | VVersion Version   | VRange   VersionRange   | VPkgs    [(Item, [Item], Maybe VersionRange)]+  | VXItem   String              -- for x-* fields   deriving (Show)  data Field@@ -101,9 +105,14 @@  getFieldString :: [Field] -> FieldName -> String getFieldString flds n =+  fromMaybe (error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)) $+  getFieldStringM flds n++getFieldStringM :: [Field] -> FieldName -> Maybe String+getFieldStringM flds n =   case [ s | Field f (VItem s) <- flds, f == n ] of-    [s] -> s-    _   -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)+    [] -> Nothing+    ss -> Just (last ss)  getFieldStrings :: [Field] -> [String] -> FieldName -> [String] getFieldStrings flds def n =@@ -125,3 +134,6 @@   case [ s | Field f (VVersion s) <- flds, f == n ] of     [s] -> s     _   -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)++pathModuleDir :: FilePath+pathModuleDir = "mdist"
src/MicroCabal/Env.hs view
@@ -1,23 +1,35 @@ module MicroCabal.Env(   Env(..),+  Target(..),   Backend(..),   PackageName,+  message,   ) where import MicroCabal.Cabal import MicroCabal.StackageList(PackageName)  data Env = Env {-  cabalDir :: FilePath,-  distDir  :: FilePath,-  verbose  :: Int,-  backend  :: Backend+  cabalDir :: FilePath,           -- where to install, default is $HOME/.mcabal+  distDir  :: FilePath,           -- where to build, default is dist-mcabal+  verbose  :: Int,                -- how chatty, default is 0, -1=say nothing, 0=minimal messages, 1=debug info+  depth    :: Int,                -- nesting depth for recursive builds, default is 0+  recursive:: Bool,               -- do recursive builds, default is False+  backend  :: Backend,            -- which compiler to use, default is MHS+  targets  :: [Target]            -- only build/install these   } +data Target = TgtLib | TgtExe+  deriving (Eq)+ data Backend = Backend {-  backendName    :: String,                                 -- name of backaned+  backendNameVers:: Env ->                       IO (String, Version), -- name and version   doesPkgExist   :: Env -> PackageName        -> IO Bool,   -- is the package available in the database?   buildPkgExe    :: Env -> Section -> Section -> IO (),     -- build executable the current directory   buildPkgLib    :: Env -> Section -> Section -> IO (),     -- build the package in the current directory   installPkgExe  :: Env -> Section -> Section -> IO (),     -- install the package from the current directory   installPkgLib  :: Env -> Section -> Section -> IO ()      -- install the package from the current directory   }++message :: Env -> Int -> String -> IO ()+message env level msg | verbose env >= level = putStrLn $ replicate (2 * depth env) ' ' ++ msg+                      | otherwise = return ()
src/MicroCabal/Main.hs view
@@ -4,9 +4,10 @@ import Data.Maybe import Data.Version import System.Environment+import System.Exit import System.Directory import qualified System.Info as I-import Text.Read+--import Text.Read import MicroCabal.Backend.GHC import MicroCabal.Backend.MHS import MicroCabal.Cabal@@ -15,14 +16,18 @@ import MicroCabal.Parse import MicroCabal.StackageList import MicroCabal.Unix-import MicroCabal.YAML+--import MicroCabal.YAML +version :: String+version = "MicroCabal 0.1.1.0"+ main :: IO () main = do   (env, args) <- decodeCommonArgs =<< setupEnv    case args of     [] -> usage+    ["--version"]  -> putStrLn version     "build"   : as -> cmdBuild   env as     "clean"   : as -> cmdClean   env as     "fetch"   : as -> cmdFetch   env as@@ -35,13 +40,15 @@ setupEnv :: IO Env setupEnv = do   home <- getEnv "HOME"-  let cdir = home ++ "/.mcabal"-  return Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, backend = mhsBackend }+  let cdir = home </> ".mcabal"+  return Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, depth = 0,+              backend = mhsBackend, recursive = False, targets = [TgtLib, TgtExe] }  decodeCommonArgs :: Env -> IO (Env, [String]) decodeCommonArgs env = do   let loop e ("-v"    : as) = loop e{ verbose = verbose e + 1 } as       loop e ("-q"    : as) = loop e{ verbose = -1 } as+      loop e ("-r"    : as) = loop e{ recursive = True } as       loop e ("--ghc" : as) = loop e{ backend = ghcBackend } as       loop e ("--mhs" : as) = loop e{ backend = mhsBackend } as       loop e as = return (e, as)@@ -49,16 +56,9 @@  usage :: IO () usage = do-  putStrLn "\-\Usage:\n\-\  mcabal [FLAGS] build [PKG]\n\-\  mcabal [FLAGS] clean\n\-\  mcabal [FLAGS] fetch PKG\n\-\  mcabal [FLAGS] help\n\-\  mcabal [FLAGS] install\n\-\  mcabal [FLAGS] update\n\-\"-  error "done"+  env <- setupEnv+  cmdHelp env []+  exitWith (ExitFailure 1)  ----------------------------------------- @@ -74,56 +74,75 @@ snapshotName :: FilePath snapshotName = "snapshot.yaml" --- This is a JSON document describing enumerating all releases.+-- Name of the nightly snapshot+nightlyName :: String+nightlyName = "nightly"++-- This is a JSON document enumerating all releases. stackageSourceList :: URL-stackageSourceList = URL "https://www.stackage.org/download/snapshots.json"+stackageSourceList = URL "https://stackage-haddock.haskell.org/snapshots.json" +-- prefix of URL for actual snapshot snapshotSource :: String snapshotSource = "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" -- lts/22/13.yaml --- XX This needs improvement+-- XXX This needs improvement getBestStackage :: Env -> IO URL getBestStackage env = do   -- Get source list   let dir = cabalDir env-      fsnaps = dir ++ "/" ++ snapshotsName+      fsnaps = dir </> snapshotsName   wget env stackageSourceList fsnaps   file <- readFile fsnaps   let snaps = parseSnapshots fsnaps file+{-+      -- Pick LTS snapshot       snap = snd $ last $              [(0::Int, error "no lts snapshots found")] ++              sort [ (l, r) | (lp, r) <- snaps, Just l <- [stripPrefix "lts-" lp >>= readMaybe] ]       snap' = map (\ c -> if c == '-' || c == '.' then '/' else c) snap-  when (verbose env > 0) $-    putStrLn $ "Picking Stackage snapshot " ++ snap-  return $ URL $ snapshotSource ++ snap' ++ ".yaml"+      snapURL = URL $ snapshotSource ++ snap' ++ ".yaml"+-}+      -- Pick a nightly snapshot+      snap = fromMaybe (error "no nightly snapshot found") $ lookup nightlyName snaps+      snap' = fixLeading0 $ map (\ c -> if c == '-' then '/' else c) snap+      fixLeading0 ('/':'0':cs) = '/' : fixLeading0 cs+      fixLeading0 (c:cs) = c : fixLeading0 cs+      fixLeading0 cs = cs+      snapURL = URL $ snapshotSource ++ snap' ++ ".yaml"+  message env 1 $ "Picking Stackage snapshot " ++ snap+  return $ snapURL  cmdUpdate :: Env -> [String] -> IO ()-cmdUpdate env _args = do-  when (verbose env >= 0) $-    putStrLn "Retrieving Stackage package list"+cmdUpdate env [] = do+  message env 0 "Retrieving Stackage package list"   let dir = cabalDir env-      stk = dir ++ "/" ++ snapshotName-      fpkgs = dir ++ "/" ++ packageListName+      stk = dir </> snapshotName+      fpkgs = dir </> packageListName   mkdir env dir   url <- getBestStackage env   wget env url stk   file <- readFile stk   let yml = parseYAML stk file       pkgs = yamlToStackageList yml+      ghcVersion = yamlToGHCVersion yml+--  putStrLn $ "==== " ++ ghcVersion --  putStrLn $ showYAML yml --  putStrLn $ show pkgs-  when (verbose env > 0) $-    putStrLn $ "Write package list to " ++ fpkgs-  writeFile fpkgs $ unlines $ map showPackage pkgs--cmdTest :: Env -> [String] -> IO ()-cmdTest _ _ = do-  let stk = "11.yaml"-  file <- readFile stk-  let yml = parseYAML stk file-  putStrLn $ showYAML yml+  message env 1 $ "Write package list to " ++ fpkgs+  writeFile fpkgs $ unlines $ map showPackage $ pkgs ++ distPkgs+  writeFile (dir </> "ghc-version") ghcVersion+cmdUpdate _ _ = usage +-- These packages are part of the ghc distribution, so they are+-- not in the stackage list.+-- XXX What to do about versions?+-- XXX more...+distPkgs :: [StackagePackage]+distPkgs =+  [ StackagePackage "containers" (makeVersion [0,6,8]) False []+  , StackagePackage "mtl"        (makeVersion [2,3,1]) False []+  ]  ----------------------------------------- @@ -133,11 +152,10 @@ getPackageList :: Env -> IO [StackagePackage] getPackageList env = do   let dir = cabalDir env-      fpkgs = dir ++ "/" ++ packageListName+      fpkgs = dir </> packageListName   b <- doesFileExist fpkgs   when (not b) $ do-    when (verbose env >= 0) $-      putStrLn "No package list, running 'update' command"+    message env 0 "No package list, running 'update' command"     cmdUpdate env []   map readPackage . lines <$> readFile fpkgs @@ -147,27 +165,27 @@   return $ fromMaybe (error $ "getPackageInfo: no package " ++ pkg) $ listToMaybe $ filter ((== pkg) . stName) pkgs  dirPackage :: Env -> FilePath-dirPackage env = cabalDir env ++ "/packages"+dirPackage env = cabalDir env </> "packages"  dirForPackage :: Env -> StackagePackage -> FilePath-dirForPackage env st = dirPackage env ++ "/" ++ stName st ++ "-" ++ showVersion (stVersion st)+dirForPackage env st = dirPackage env </> stName st ++ "-" ++ showVersion (stVersion st)  cmdFetch :: Env -> [String] -> IO () cmdFetch env [pkg] = do   st <- getPackageInfo env pkg   let pkgs = stName st ++ "-" ++ showVersion (stVersion st)-      url  = URL $ hackageSrcURL ++ pkgs ++ "/" ++ pkgz+      url  = URL $ hackageSrcURL ++ pkgs </> pkgz       pkgz = pkgs ++ ".tar.gz"       pdir = dirForPackage env st       file = pdir ++ ".tar.gz"   b <- doesDirectoryExist pdir-  when (not b) $ do+  if b then+    message env 1 $ "Already in " ++ pdir+   else do     mkdir env pdir-    when (verbose env > 0) $-      putStrLn $ "Fetching  " ++ pkgz+    message env 1 $ "Fetching  " ++ pkgz     wget env url file-    when (verbose env > 0) $-      putStrLn $ "Unpacking " ++ pkgz+    message env 1 $ "Unpacking " ++ pkgz ++ " in " ++ pdir     tarx env (dirPackage env) file cmdFetch _ _ = usage @@ -184,15 +202,14 @@ cmdBuild :: Env -> [String] -> IO () cmdBuild env [] = build env cmdBuild env [pkg] = do+  message env 0 $ "Build package " ++ pkg   st <- getPackageInfo env pkg   let dir = dirForPackage env st   b <- doesDirectoryExist dir   when (not b) $ do-    when (verbose env >= 0) $-      putStrLn $ "Package not found, running 'fetch " ++ pkg ++ "'"+    message env 0 $ "Package not found, running 'fetch " ++ pkg ++ "'"     cmdFetch env [pkg]-  when (verbose env >= 0) $-    putStrLn $ "Building in " ++ dir+  message env 0 $ "Building in " ++ dir   setCurrentDirectory dir   cmdBuild env [] cmdBuild _ _ = usage@@ -201,42 +218,64 @@ getGlobal (Cabal sects) =   fromMaybe (error "no global section") $ listToMaybe [ s | s@(Section "global" _ _) <- sects ] +createPathFile :: Env -> Section -> IO ()+createPathFile env (Section _ name _) = do+  let mdlName = "Paths_" ++ map (\ c -> if c == '-' then '_' else c) name+      pathName = pathModuleDir </> mdlName ++ ".hs"+  message env 1 $ "Creating path module " ++ pathName+  mkdir env pathModuleDir+  writeFile pathName $+    "module " ++ mdlName ++ " where\n" +++    "-- nothing yet\n"+ build :: Env -> IO () build env = do   fn <- findCabalFile env   rfile <- readFile fn+  comp <- backendNameVers (backend env) env   let cbl = parseCabal fn rfile-      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp }       ncbl@(Cabal sects) = normalize info cbl       glob = getGlobal ncbl-      sect s@(Section "executable" _ _) = buildExe env glob s-      sect s@(Section "library"    _ _) = buildLib env glob s+      sect s@(Section "executable" _ _) | TgtExe `elem` targets env = buildExe env glob s+      sect s@(Section "library"    _ _) | TgtLib `elem` targets env = buildLib env glob s       sect _ = return ()-  mapM_ sect sects+  mapM_ sect $ addMissing sects  buildExe :: Env -> Section -> Section -> IO ()-buildExe env glob sect@(Section _ _ flds) = do+buildExe env glob sect@(Section _ name flds) = do+  message env 0 $ "Building executable " ++ name+  createPathFile env sect   let deps = getBuildDepends flds       pkgs = [ p | (p, _, _) <- deps ]   mapM_ (checkDep env) pkgs   buildPkgExe (backend env) env glob sect  buildLib :: Env -> Section -> Section -> IO ()-buildLib env glob sect@(Section _ _ flds) = do+buildLib env glob sect@(Section _ name flds) = do+  message env 0 $ "Building library " ++ name+  createPathFile env sect   let pkgs = getBuildDependsPkg flds   mapM_ (checkDep env) pkgs   buildPkgLib (backend env) env glob sect  checkDep :: Env -> PackageName -> IO ()-checkDep _env pkg | pkg `elem` builtinPackages = return () checkDep env pkg = do   let bend = backend env   b <- doesPkgExist bend env pkg   when (not b) $-    error $ "dependency not installed: " ++ pkg+    if recursive env then do+      let env' = env { depth = depth env + 1 }+      preserveCurrentDirectory $+        cmdInstallLib env' [pkg]+    else+      error $ "dependency not installed: " ++ pkg -builtinPackages :: [String]-builtinPackages = ["base", "directory", "process", "bytestring", "text", "fail", "time"]+-- If there is no section, except the global one, then just make a+-- library section.+addMissing :: [Section] -> [Section]+addMissing [glb@(Section "global" _ flds)] = [glb, Section "library" (getFieldString flds "name") flds]+addMissing sects = sects  ----------------------------------------- @@ -246,29 +285,61 @@   cmdBuild env args   install env +cmdInstallLib :: Env -> [String] -> IO ()+cmdInstallLib env args = cmdInstall env{ targets = [TgtLib] } args+ install :: Env -> IO () install env = do   fn <- findCabalFile env   rfile <- readFile fn+  comp <- backendNameVers (backend env) env   let cbl = parseCabal fn rfile-      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp }       ncbl@(Cabal sects) = normalize info cbl       glob = getGlobal ncbl-      sect s@(Section "executable" _ _) = installExe env glob s-      sect s@(Section "library"    _ _) = installLib env glob s+      sect s@(Section "executable" _ _) | TgtExe `elem` targets env = installExe env glob s+      sect s@(Section "library"    _ _) | TgtLib `elem` targets env = installLib env glob s       sect _ = return ()-  mapM_ sect sects+  mapM_ sect $ addMissing sects  installExe :: Env -> Section -> Section -> IO ()-installExe env = installPkgExe (backend env) env+installExe env glob sect@(Section _ name _) = do+  message env 0 $ "Installing executable " ++ name+  installDataFiles env glob sect+  installPkgExe (backend env) env glob sect  installLib :: Env -> Section -> Section -> IO ()-installLib env = installPkgLib (backend env) env+installLib env glob sect@(Section _ name _) = do+  message env 0 $ "Installing library " ++ name+  installDataFiles env glob sect+  installPkgLib (backend env) env glob sect +installDataFiles :: Env -> Section -> Section -> IO ()+installDataFiles _env _glob _sect@(Section _ _ _flds) = do+  -- Not yet+  return ()+ -----------------------------------------  cmdHelp :: Env -> [String] -> IO ()-cmdHelp _ _ = putStrLn "Coming soon"+cmdHelp _ _ = putStrLn "\+  \Available commands:\n\+  \  mcabal [FLAGS] build [PKG]    build in current directory, or the package PKG\n\+  \  mcabal [FLAGS] clean          clean in the current directory\n\+  \  mcabal [FLAGS] fetch PKG      fetch files for package PKG\n\+  \  mcabal [FLAGS] help           show this message\n\+  \  mcabal [FLAGS] install        build and install in current directory\n\+  \  mcabal [FLAGS] parse FILE     just parse a Cabal file (for debugging)\n\+  \  mcabal [FLAGS] update         retrieve new set of consistent packages\n\+  \\n\+  \Flags:\n\+  \  -v                            be more verbose (can be repeated)\n\+  \  -q                            be quiet\n\+  \  -r                            do recursive installs for missing packages\n\+  \  --ghc                         compile using ghc\n\+  \  --mhs                         compile using mhs (default)\n\+  \\n\+  \"  ----------------------------------------- @@ -278,10 +349,11 @@ -----------------------------------------  cmdParse :: Env -> [String] -> IO ()-cmdParse _env [fn] = do+cmdParse env [fn] = do   rfile <- readFile fn+  comp <- backendNameVers (backend env) env   let cbl = parseCabal fn rfile-      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+      info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp }       ncbl = normalize info cbl   --putStrLn $ showCabal cbl   putStrLn $ showCabal ncbl
src/MicroCabal/Normalize.hs view
@@ -3,6 +3,7 @@ import Data.List import Data.Maybe import MicroCabal.Cabal+--import Debug.Trace  -- Do some normalization --  * computre conditionals and flatten 'if/else'@@ -28,6 +29,7 @@ combineValue _ (VItems xs) (VItems ys) = VItems (xs ++ ys) combineValue _ (VBool x) (VBool y) = VBool (x && y) combineValue _ (VPkgs xs) (VPkgs ys) = VPkgs (xs ++ ys)+combineValue _ (VXItem x) (VXItem y) = VXItem (x ++ "\n" ++ y) combineValue n v1 v2 = error $ "fields " ++ show n ++ " cannot be combined, values=" ++ show (v1, v2)  inline :: Cabal -> Cabal@@ -43,7 +45,7 @@ libName (Cabal (g@(Section _ _ gs):ss)) = Cabal $ g : map set ss   where set (Section "library" "" fs) = Section "library" name fs         set s = s-        name = head $ [ n | Field "name" (VItem n) <- gs ] ++ [error "no name field"]  +        name = getFieldString gs "name"  reduce :: FlagInfo -> Cabal -> Cabal reduce info c = reduce' (addFlags c) c@@ -54,7 +56,8 @@  reduce' :: FlagInfo -> Cabal -> Cabal reduce' info = mapField red-  where red (If c t e) | cond info c = concatMap red t+  where red (If c t e) --x | trace ("if " ++ show (c, cond info c)) False = undefined+                       | cond info c = concatMap red t                        | otherwise   = concatMap red e         red f = [f] @@ -75,4 +78,12 @@         eval (Cimpl s mv) = n == s && maybe True (inVersionRange v) mv  where (n, v) = impl info  inVersionRange :: Version -> VersionRange -> Bool-inVersionRange _ _ = True  -- XXX+inVersionRange v (VEQ v') = v == v'+inVersionRange v (VGT v') = v >  v'+inVersionRange v (VLT v') = v <  v'+inVersionRange v (VLE v') = v <= v'+inVersionRange v (VGE v') = v >= v'+inVersionRange v (VOr vr1 vr2) = inVersionRange v vr1 || inVersionRange v vr2+inVersionRange v (VAnd vr1 vr2) = inVersionRange v vr1 && inVersionRange v vr2+inVersionRange v (VEQSet vs) = v `elem` vs+inVersionRange _ vr = error $ "inVersionRange: not implemented " ++ show vr
src/MicroCabal/Parse.hs view
@@ -2,12 +2,14 @@   parseCabal,   parseYAML,   parseSnapshots,+  readVersion,   ) where import Control.Applicative import Control.Monad import Data.Char import Data.List import Data.Maybe+import Data.Version import Text.ParserComb import MicroCabal.Cabal import MicroCabal.YAML@@ -24,7 +26,7 @@  runP :: P a -> FilePath -> String -> a runP prsr fn file =-  case runPrsr prsr (initLexState file) of+  case runPrsr prsr (initLexState (preLex file)) of     Left (LastFail n ts msgs) -> error $ "\n" ++       "  found:    " ++ (map show ts ++ ["EOF"]) !! 0 ++ "\n" ++       "  expected: " ++ unwords (nub msgs) ++ "\n" ++@@ -35,6 +37,17 @@     Right (a:_) -> a     Right []    -> undefined -- impossible +-- Fixup of '\r' and '\t'+preLex :: [Char] -> [Char]+preLex = loop 0+  where+    loop :: Int -> [Char] -> [Char]+    loop _ [] = []+    loop _ ('\n':cs) = '\n' : loop 0     cs+    loop _ ('\r':cs) =        loop 0     cs+    loop n ('\t':cs) = replicate k ' ' ++ loop 0 cs+         where k = 8 - n `rem` 8+    loop n (c:cs)    = c    : loop (n+1) cs  ------------------------------ @@ -58,17 +71,14 @@   tmNextToken (LS i [] (c:cs)) | c == '\n' = (c, LS     0 [] cs)                                | otherwise = (c, LS (i+1) [] cs)   tmNextToken (LS i kks@(k:ks) (c:cs)) | c /= '\n' = (c, LS (i+1) kks cs)-                                       | Just cs' <- skipEmpty cs = tmNextToken (LS i kks cs')                                        | otherwise =-    let lead 0     _             =---          trace ("Just NL kks=" ++ show kks ++ " cs=" ++ show (take 10 cs))-          ('\n', LS 0 kks cs)              -- There are at least k leading spaces-        lead j (x:xs) | x == ' ' = lead (j-1) xs                    -- Count spaces---                      | x == '-' = ('\n', LS 0 kks cs)-        lead _     _             =---          trace ("insert FS kks=" ++ show kks ++ " cs=" ++ show (take 10 cs))-          (fieldSep, LS 0 ks (c:cs))                 -- Fewer than k spaces.  Generate FS, pop, and try again.-    in  lead (k+1) cs+    case skipEmpty cs of+      Just cs' -> tmNextToken (LS i kks cs')+      _ ->+        let lead 0     _             = ('\n', LS 0 kks cs)              -- There are at least k leading spaces+            lead j (x:xs) | x == ' ' = lead (j-1) xs                    -- Count spaces+            lead _     _             = (fieldSep, LS 0 ks (c:cs))       -- Fewer than k spaces.  Generate FS, pop, and try again.+        in  lead (k+1) cs   tmRawTokens (LS _ _ cs) = cs  skipEmpty :: String -> Maybe String@@ -162,6 +172,8 @@         <|< pParens pVersionRange         <|< (pStr "=="  *> pVEq)         <|< (pStr "^>=" *> pVGEHat)+        <|< (VGE (makeVersion [0]) <$ pStr "-any")+        <|< (VLT (makeVersion [0]) <$ pStr "-none")     pVEq  = (VEQSet <$> pVSet) <|< do       v <- pVersion       (VEQWild v <$ pStr ".*") <|< pure (VEQ v)@@ -169,7 +181,7 @@     pVGEHat = (VGEHat <$> pVersion) <|< (VGEHatSet <$> pVSet)  pVOper :: P (Version -> VersionRange)-pVOper = pSpaces *> choice [ VGT <$ pStr ">", VGT <$ pStr "<", VGT <$ pStr "<=", VGT <$ pStr ">="]+pVOper = pSpaces *> choice [ VGT <$ pStr ">", VLT <$ pStr "<", VGE <$ pStr ">=", VLE <$ pStr "<="]  pStr :: String -> P () pStr s = pSpaces *> p s@@ -206,23 +218,28 @@ pComma = pWhite *> pChar ','  pCommaList :: P a -> P [a]-pCommaList p = (pStr "," *> esepBy1 p pComma)+pCommaList p = (pStrW "," *> esepBy1 p pComma)   <|< pCommaList' p  pCommaList' :: P a -> P [a] pCommaList' p = esepBy p pComma <* eoptional (pStr ",")  pSpaceList :: P a -> P [a]-pSpaceList p = esepBy p pWhite+pSpaceList p = esepBy p' pWhite+  where+    -- sometimes (kan-extensions.cabal) there is a spurious comma,+    -- so allow that+    p' = p <* eoptional (pStr ",")  pOptCommaList :: P a -> P [a]-pOptCommaList p = --pSpaceList p <|> pCommaList p+pOptCommaList p =     (pStrW "," *> pCommaList' p)   -- it starts with a ',', so it must be comma separated   <|< do     a <- p  -- parse one item     -- now check if we have a comma or not, and pick the parser for the rest     as <- (pStrW "," *> pCommaList' p) <|< pSpaceList p     return (a:as)+  <|< ([] <$ pWhite)  pVComma :: P Value pVComma = VItems <$> pCommaList pItem@@ -269,6 +286,7 @@     pure $ If c t e    else do     pColon+--    traceM $ "parser " ++ fn     let p = getParser fn     v <- p     pFieldSep@@ -288,13 +306,19 @@         <|< (pKeyWordNC "os"   *> pParens (Cos   <$> pName))         <|< pParens pCond -pFreeText :: P Value-pFreeText = do+pFreeText' :: P String+pFreeText' = do   txt <- satisfyMany (\ c -> c /= end && c /= fieldSep)   let dot "." = ""  -- Single '.' used to make an empty line       dot s   = s-  pure $ VItem $ unlines . map (dot . dropWhile (== ' ')) . lines $ txt+  pure $ unlines . map (dot . dropWhile (== ' ')) . lines $ txt +pFreeText :: P Value+pFreeText = VItem <$> pFreeText'++pFreeTextX :: P Value+pFreeTextX = VXItem <$> pFreeText'+ pFieldName :: P FieldName pFieldName = pIdent @@ -309,18 +333,19 @@  pSection :: P Section pSection = pWhite *> (-      Section <$> pKeyWordNC "common"     <*>           pName <*> pFields-  <|< Section <$> pKeyWordNC "library"    <*>         libName <*> pFields-  <|< Section <$> pKeyWordNC "executable" <*>           pName <*> pFields+      Section <$> pKeyWordNC "common"            <*>    pName <*> pFields+  <|< Section <$> pKeyWordNC "library"           <*>  libName <*> pFields+  <|< Section <$> pKeyWordNC "executable"        <*>    pName <*> pFields   <|< Section <$> pKeyWordNC "source-repository" <*>    pName <*> pFields   <|< Section <$> pKeyWordNC "flag"              <*>    pName <*> pFields   <|< Section <$> pKeyWordNC "test-suite"        <*>    pName <*> pFields+  <|< Section <$> pKeyWordNC "benchmark"         <*>    pName <*> pFields   )   where libName = pName <|< pure ""  getParser :: FieldName -> P Value getParser f =-  if "x-" `isPrefixOf` f then pFreeText else+  if "x-" `isPrefixOf` f then pFreeTextX else   fromMaybe (error $ "Unknown field: " ++ f) $ lookup f parsers  parsers :: [(FieldName, P Value)]@@ -330,18 +355,19 @@   , "autogen-includes"               # pVOptComma   , "autogen-modules"                # pVComma   , "build-depends"                  # pVLibs-  , "build-tool-depends"             # pVComma -- XXX+  , "build-tool-depends"             # pVLibs  -- ??? pVComma -- XXX   , "build-tools"                    # pVComma -- XXX   , "buildable"                      # (VBool <$> pBool)   , "c-sources"                      # pVComma   , "cc-options"                     # pVComma   , "cmm-sources"                    # pVComma   , "cmm-options"                    # pVComma-  , "cpp-options"                    # pVComma+  , "cpp-options"                    # pVOptComma   , "cxx-options"                    # pVComma   , "default-extensions"             # pVOptComma   , "default-language"               # (VItem <$> pItem)   , "exposed-modules"                # pVOptComma+  , "reexported-modules"             # pVOptComma   , "extensions"                     # pVOptComma   , "extra-bundled-libraries"        # pVComma   , "extra-dynamic-library-flavours" # pVComma@@ -381,9 +407,9 @@   , "category"                       # pFreeText   , "copyright"                      # pFreeText   , "data-dir"                       # pVSpace-  , "data-files"                     # pVComma+  , "data-files"                     # pVOptComma   , "description"                    # pFreeText-  , "extra-doc-files"                # pVComma+  , "extra-doc-files"                # pVOptComma   , "extra-source-files"             # pVOptComma   , "extra-tmp-files"                # pVComma   , "homepage"                       # pFreeText@@ -395,8 +421,8 @@   , "package-url"                    # pFreeText   , "stability"                      # pFreeText   , "subdir"                         # pFreeText-  , "synopsis"                       # pFreeText-  , "tested-with"                    # pVOptComma+  , "synopsis"                       # pFreeTextX+  , "tested-with"                    # pFreeText   , "version"                        # (VVersion <$> pVersion)   -- test suite fields                 , "main-is"                        # (VItem <$> pItem)@@ -477,3 +503,8 @@  pSnapshot :: P Snapshot pSnapshot = (,) <$> (pWhite *> pString) <*> (pWhite *> pChar ':' *> pWhite *> pString)++----------------------------------------------------------------------++readVersion :: String -> Version+readVersion = makeVersion . map read . words . map (\ c -> if c == '.' then ' ' else c)
src/MicroCabal/StackageList.hs view
@@ -5,6 +5,8 @@   showPackage,   readPackage,   yamlToStackageList,+  yamlToGHCVersion,+  readVersionM,   ) where import Data.Maybe import Data.Version@@ -32,7 +34,7 @@   case words spkg of     name : vers : hide : flgs ->       StackagePackage { stName = name, stVersion = readVersion vers, stHidden = read hide, stFlags = map flag flgs }-    _ -> error "readPackage"+    x -> error $ "readPackage" ++ show x   where flag s = (n, read (drop 1 b)) where (n, b) = span (/= '=') s  yamlToStackageList :: YAMLValue -> [StackagePackage]@@ -44,6 +46,24 @@         _ -> error "Unrecognized Stackage package list format" yamlToStackageList _ = error "Unrecognized Stackage package list format" +-- XXX Ugly, ugly hack because the YAML parser is brtoken.+yamlToGHCVersion :: YAMLValue -> String+yamlToGHCVersion (YRecord flds) =+  let bad n = error "yamlToGHCVersion: Unrecognized Stackage package list format " ++ show (n::Int)+  in  case lookup "packages" flds of+        Just (YArray packages) ->+          case last packages of+            YRecord pflds ->+              case lookup "resolver" pflds of+                Just (YRecord rflds) ->+                  case lookup "compiler" rflds of+                    Just (YString s) -> s+                    _ -> bad 1+                _ -> bad 2+            _ -> bad 3+        _ -> bad 4+yamlToGHCVersion _ = error "Unrecognized Stackage package list format"+ addFlags :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage addFlags flags st = maybe st (\ f -> st{ stFlags = yflags f }) $ lookup (stName st) flags   where yflags (YRecord r) = [(n, b) | (n, YBool b) <- r]@@ -64,7 +84,7 @@ decodePackage y = error $ "Bad package desc " ++ show y  readVersion :: String -> Version-readVersion s = fromMaybe (error $ "decodePackage: bad version " ++ s) $ readVersionM s+readVersion s = fromMaybe (error $ "readVersion: bad version " ++ s) $ readVersionM s  readVersionM :: String -> Maybe Version readVersionM s = makeVersion <$> (mapM readMaybe . words . map (\ c -> if c == '.' then ' ' else c) $ s)
src/MicroCabal/Unix.hs view
@@ -1,14 +1,15 @@ module MicroCabal.Unix(-  cmd, tryCmd, cmdOut,+  cmd, tryCmd, cmdOut, tryCmdOut,   mkdir,   wget, URL(..),   tarx,   rmrf,   cp,   copyFiles,+  preserveCurrentDirectory,+  (</>),   ) where import Control.Exception-import Control.Monad import Data.Maybe import System.Directory import System.Environment@@ -20,31 +21,44 @@  cmd :: Env -> String -> IO () cmd env s = do-  when (verbose env > 1) $-    putStrLn $ "cmd: " ++ s+  message env 2 $ "cmd: " ++ s   callCommand s  tryCmd :: Env -> String -> IO Bool-tryCmd env s = catch (cmd env s >> return True) (\ (_ :: SomeException) -> return False)+tryCmd env s = catch (cmd env s >> return True) f+  where f :: SomeException -> IO Bool+        f _ = return False  cmdOut :: Env -> String -> IO String cmdOut env s = do   (fn, h) <- tmpFile   hClose h-  cmd env $ s ++ ">" ++ fn+  cmd env $ s ++ " >" ++ fn   o <- readFile fn   removeFile fn   return o +tryCmdOut :: Env -> String -> IO (Maybe String)+tryCmdOut env s = do+  (fn, h) <- tmpFile+  hClose h+  b <- tryCmd env $ s ++ " >" ++ fn+  if b then do+    o <- readFile fn+    removeFile fn+    return (Just o)+   else+    return Nothing+ tmpFile :: IO (String, Handle) tmpFile = do   mtmp <- lookupEnv "TMPDIR"   let tmp = fromMaybe "/tmp" mtmp       tmplt = "mcabal.txt"   res <- try $ openTempFile tmp tmplt-  case res of+  case res :: Either SomeException (String, Handle) of     Right x -> return x-    Left (_::SomeException) -> openTempFile "." tmplt+    Left  _ -> openTempFile "." tmplt   ---------@@ -74,3 +88,15 @@ copyFiles :: Env -> FilePath -> [FilePath] -> FilePath -> IO () copyFiles env src fns tgt = do   cmd env $ "cd " ++ src ++ "; tar cf - " ++ unwords fns ++ " | (cd " ++ tgt ++ "; tar xf - )"++preserveCurrentDirectory :: IO a -> IO a+preserveCurrentDirectory io = do+  cwd <- getCurrentDirectory+  a <- io+  setCurrentDirectory cwd+  return a++-----++(</>) :: FilePath -> FilePath -> FilePath+x </> y = x ++ "/" ++ y
src/Text/ParserComb.hs view
@@ -31,10 +31,10 @@ maxInt :: Int maxInt = 1000000000 -noFail :: forall t . LastFail t+noFail :: LastFail t noFail = LastFail maxInt [] [] -longest :: forall t . LastFail t -> LastFail t -> LastFail t+longest :: LastFail t -> LastFail t -> LastFail t longest lf1@(LastFail l1 t1 x1) lf2@(LastFail l2 _ x2) =   if l1 < l2 then     lf1@@ -43,17 +43,17 @@   else     LastFail l1 t1 (x1 ++ x2) -longests :: forall t . [LastFail t] -> LastFail t+longests :: [LastFail t] -> LastFail t longests xs = foldl1 longest xs  class TokenMachine tm t | tm -> t where   tmNextToken :: tm -> (t, tm)   tmRawTokens :: tm -> [t] -tmLeft :: forall tm t . TokenMachine tm t => tm -> Int+tmLeft :: TokenMachine tm t => tm -> Int tmLeft = length . tmRawTokens -firstToken :: forall tm t . TokenMachine tm t => tm -> [t]+firstToken :: TokenMachine tm t => tm -> [t] firstToken tm =   case tmNextToken tm of     (t, _) -> [t]@@ -64,23 +64,23 @@ data Prsr tm t a = P (tm -> Res tm t a) --instance Show (Prsr s t a) where show _ = "<<Prsr>>" -runP :: forall tm t a . Prsr tm t a -> (tm -> Res tm t a)+runP :: Prsr tm t a -> (tm -> Res tm t a) runP (P p) = p -mapTokenState :: forall tm t . (tm -> tm) -> Prsr tm t ()+mapTokenState :: (tm -> tm) -> Prsr tm t () mapTokenState f = P (\ tm -> Many [((), f tm)] noFail) -instance forall tm t . Functor (Prsr tm t) where+instance Functor (Prsr tm t) where   fmap f p = P $ \ t ->     case runP p t of       Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf -instance forall tm t . Applicative (Prsr tm t) where+instance Applicative (Prsr tm t) where   pure a = P $ \ t -> Many [(a, t)] noFail   (<*>) = ap   (*>) p k = p >>= \ _ -> k -instance forall tm t . Monad (Prsr tm t) where+instance Monad (Prsr tm t) where   (>>=) p k = P $ \ t ->     case runP p t of       Many aus plf ->@@ -90,10 +90,10 @@         in  Many rrs (longests (plf : lfs))   return = pure -instance forall t tm . TokenMachine tm t => MonadFail (Prsr tm t) where+instance TokenMachine tm t => MonadFail (Prsr tm t) where   fail m = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) [m]) -instance forall t tm . TokenMachine tm t => Alternative (Prsr tm t) where+instance TokenMachine tm t => Alternative (Prsr tm t) where   empty = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) ["empty"])    (<|>) p q = P $ \ t ->@@ -104,7 +104,7 @@  -- Left biased choice infixl 3 <|<-(<|<) :: forall tm t a . Prsr tm t a -> Prsr tm t a -> Prsr tm t a+(<|<) :: Prsr tm t a -> Prsr tm t a -> Prsr tm t a (<|<) p q = P $ \ t ->   case runP p t of     Many [] lfa ->@@ -112,19 +112,21 @@          Many b lfb -> Many b (longest lfa lfb)     r -> r -satisfy :: forall tm t . TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t+satisfy :: TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t satisfy msg f = P $ \ acs ->   case tmNextToken acs of     r@(c, _) | f c -> Many [r] noFail     _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg]) -satisfyM :: forall tm t a . TokenMachine tm t => String -> (t -> Maybe a) -> Prsr tm t a+satisfyM :: TokenMachine tm t => String -> (t -> Maybe a) -> Prsr tm t a satisfyM msg f = P $ \ acs ->   case tmNextToken acs of-    (c, cs) | Just a <- f c -> Many [(a, cs)] noFail-    _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])+    (c, cs) ->+      case f c of+        Just a  -> Many [(a, cs)] noFail+        Nothing -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg]) -satisfyMany :: forall tm t . TokenMachine tm t => (t -> Bool) -> Prsr tm t [t]+satisfyMany :: TokenMachine tm t => (t -> Bool) -> Prsr tm t [t] satisfyMany f = P $ loop []   where loop res acs =           case tmNextToken acs of@@ -132,7 +134,7 @@                     | otherwise -> Many [(reverse res, acs)] noFail  infixl 9 <?>-(<?>) :: forall tm t a . Prsr tm t a -> String -> Prsr tm t a+(<?>) :: Prsr tm t a -> String -> Prsr tm t a (<?>) p e = P $ \ t -> --  trace ("<?> " ++ show e) $   case runP p t of@@ -146,7 +148,7 @@     _                          -> Many [((), t)] noFail -} -nextToken :: forall tm t . TokenMachine tm t => Prsr tm t t+nextToken :: TokenMachine tm t => Prsr tm t t nextToken = P $ \ cs ->   case tmNextToken cs of     (c, _) -> Many [(c, cs)] noFail@@ -167,7 +169,7 @@     _         -> Many [] (LastFail (length ts) (take 1 ts) ["!"]) -} -runPrsr :: forall tm t a . --X(Show a, Show s) =>+runPrsr ::  --X(Show a, Show s) =>            Prsr tm t a -> tm -> Either (LastFail t) [a] runPrsr (P p) f =   case p f of@@ -176,31 +178,31 @@  ------------------------------- -emany :: forall tm t a . Prsr tm t a -> Prsr tm t [a]+emany :: Prsr tm t a -> Prsr tm t [a] emany p = esome p <|< pure [] -esome :: forall tm t a . Prsr tm t a -> Prsr tm t [a]+esome :: Prsr tm t a -> Prsr tm t [a] esome p = (:) <$> p <*> emany p -eoptional :: forall tm t a . Prsr tm t a -> Prsr tm t (Maybe a)+eoptional :: Prsr tm t a -> Prsr tm t (Maybe a) eoptional p = (Just <$> p) <|< pure Nothing -choice :: forall tm t a . TokenMachine tm t => [Prsr tm t a] -> Prsr tm t a+choice :: TokenMachine tm t => [Prsr tm t a] -> Prsr tm t a choice [] = empty choice ps = foldr1 (<|>) ps -sepBy1 :: forall tm t a sep . TokenMachine tm t => Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+sepBy1 :: TokenMachine tm t => Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] sepBy1 p sep = (:) <$> p <*> many (sep *> p) -esepBy1 :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] esepBy1 p sep = (:) <$> p <*> emany (sep *> p) -esepBy :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] esepBy p sep = esepBy1 p sep <|< pure [] -esepEndBy :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepEndBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] esepEndBy p sep = esepEndBy1 p sep <|< pure [] -esepEndBy1 :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepEndBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure [])