MicroCabal 0.2.0.0 → 0.2.1.0
raw patch · 9 files changed
+244/−66 lines, 9 files
Files
- MicroCabal.cabal +4/−2
- src/MicroCabal/Backend/GHC.hs +21/−21
- src/MicroCabal/Backend/MHS.hs +21/−17
- src/MicroCabal/Cabal.hs +0/−4
- src/MicroCabal/Env.hs +11/−1
- src/MicroCabal/Glob.hs +45/−0
- src/MicroCabal/Main.hs +35/−20
- src/MicroCabal/Parse.hs +6/−1
- src/MicroCabal/Regex.hs +101/−0
MicroCabal.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: MicroCabal-version: 0.2.0.0+version: 0.2.1.0 synopsis: A partial Cabal replacement license: Apache-2.0 license-file: LICENSE@@ -26,13 +26,15 @@ 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: MultiParamTypeClasses+ default-extensions: MultiParamTypeClasses ScopedTypeVariables PatternGuards other-modules: MicroCabal.Backend.GHC MicroCabal.Backend.MHS MicroCabal.Cabal MicroCabal.Env+ MicroCabal.Glob MicroCabal.Normalize MicroCabal.Parse+ MicroCabal.Regex MicroCabal.StackageList MicroCabal.Unix MicroCabal.YAML
src/MicroCabal/Backend/GHC.hs view
@@ -8,31 +8,31 @@ import MicroCabal.Parse(readVersion) import MicroCabal.Unix -ghcBackend :: Backend-ghcBackend = Backend {- backendNameVers = ghcNameVers,- doesPkgExist = ghcExists,- buildPkgExe = ghcBuildExe,- buildPkgLib = ghcBuildLib,- installPkgExe = ghcInstallExe,- 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.+ghcBackend :: Env -> IO Backend+ghcBackend env = do+ -- Actual GHC version.+ numVersion <- takeWhile (/= '\n') <$> cmdOut env "ghc --numeric-version"+ -- GHC version used in the stackage snapshot. snapVersion <- readFile (cabalDir env </> "ghc-version")- let ghcVersion = "ghc-" ++ svers+ let ghcVersion = "ghc-" ++ numVersion+ version = readVersion numVersion+ -- Check that the ghc version is the one that the Stackage snapshot wants. when (snapVersion /= ghcVersion) $ error $ "The Stackage snapshot files are for " ++ snapVersion ++ ", but the current compiler is " ++ ghcVersion- return ("ghc", readVersion svers) + return Backend {+ compilerName = "ghc",+ compilerVersion = version,+ compiler = ghcVersion,+ doesPkgExist = ghcExists,+ buildPkgExe = ghcBuildExe,+ buildPkgLib = ghcBuildLib,+ installPkgExe = ghcInstallExe,+ installPkgLib = ghcInstallLib+ }+ getGhcName :: Env -> IO FilePath-getGhcName env = do- (n, v) <- ghcNameVers env- return $ n ++ "-" ++ showVersion v+getGhcName env = return $ compiler $ backend env getGhcDir :: Env -> IO FilePath getGhcDir env = (cabalDir env </>) <$> getGhcName env@@ -76,7 +76,7 @@ buildDir <- getBuildDir env return $ [ "-package-env=-", "-package-db=" ++ db, "-outputdir=" ++ buildDir, "-w"] ++ map ("-i" ++) srcDirs ++- ["-i" ++ pathModuleDir] +++ ["-i" ++ pathModuleDir env] ++ map ("-I" ++) incDirs ++ map ("-X" ++) exts ++ lang ++
src/MicroCabal/Backend/MHS.hs view
@@ -1,24 +1,28 @@ 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 {- backendNameVers = mhsNameVers,- doesPkgExist = mhsExists,- buildPkgExe = mhsBuildExe,- buildPkgLib = mhsBuildLib,- installPkgExe = mhsInstallExe,- installPkgLib = mhsInstallLib- }+mhsBackend :: Env -> IO Backend+mhsBackend env = do+ numVersion <- takeWhile (/= '\n') <$> cmdOut env "mhs --numeric-version"+ let mhsVersion = "mhs-" ++ numVersion+ version = readVersion numVersion + return Backend {+ compilerName = "mhs",+ compilerVersion = version,+ compiler = mhsVersion,+ doesPkgExist = mhsExists,+ buildPkgExe = mhsBuildExe,+ buildPkgLib = mhsBuildLib,+ installPkgExe = mhsInstallExe,+ installPkgLib = mhsInstallLib+ } mhsNameVers :: Env -> IO (String, Version) mhsNameVers env = do@@ -48,7 +52,7 @@ -- XXX These packages are part of mhs. builtinPackages :: [String]-builtinPackages = ["array", "base", "deepseq", "directory", "process", "bytestring", "text", "fail", "time"]+builtinPackages = ["array", "base", "deepseq", "directory", "process", "bytestring", "text", "fail"] setupStdArgs :: Env -> [Field] -> [String] setupStdArgs _env flds =@@ -89,13 +93,11 @@ 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+ cmd env $ "mhs " ++ flg ++ args mhsOut :: Env -> String -> IO String mhsOut env args =- cmdOut env $ "MHSDIR=/usr/local/lib/mhs " ++ -- temporary hack- "mhs " ++ args+ cmdOut env $ "mhs " ++ args findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath findMainIs _ [] fn = error $ "cannot find " ++ show fn@@ -119,8 +121,10 @@ setupStdArgs env flds ++ ["-a."] ++ mdls+ isMdl (' ':_) = True -- Relies on -L output format+ isMdl _ = False mhs env args- pkgmdls <- lines <$> mhsOut env ("-L" ++ pkgfn)+ pkgmdls <- words . unlines . filter isMdl . 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"
src/MicroCabal/Cabal.hs view
@@ -17,7 +17,6 @@ getBuildDepends, getBuildDependsPkg, getVersion,- pathModuleDir, ) where import Data.Maybe import Data.Version@@ -134,6 +133,3 @@ 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
@@ -2,8 +2,10 @@ Env(..), Target(..), Backend(..),+ backendNameVers, PackageName, message,+ pathModuleDir, ) where import MicroCabal.Cabal import MicroCabal.StackageList(PackageName)@@ -22,7 +24,9 @@ deriving (Eq) data Backend = Backend {- backendNameVers:: Env -> IO (String, Version), -- name and version+ compilerName :: String, -- just the name, e.g., "ghc", "mhs"+ compilerVersion:: Version, -- numeric version, e.g., makeVersion [9,8,2]+ compiler :: String, -- name&version, e.g., "ghc-9.8.2" 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@@ -30,6 +34,12 @@ installPkgLib :: Env -> Section -> Section -> IO () -- install the package from the current directory } +backendNameVers :: Backend -> (String, Version)+backendNameVers b = (compilerName b, compilerVersion b)+ message :: Env -> Int -> String -> IO () message env level msg | verbose env >= level = putStrLn $ replicate (2 * depth env) ' ' ++ msg | otherwise = return ()++pathModuleDir :: Env -> FilePath+pathModuleDir env = distDir env ++ "/" ++ "autogen"
+ src/MicroCabal/Glob.hs view
@@ -0,0 +1,45 @@+module MicroCabal.Glob(+ GlobPattern,+ --glob,+ listDirectoryRecursive,+ matchFiles,+ ) where+import Control.Exception+import Control.Monad+import System.Directory+import MicroCabal.Regex+import MicroCabal.Unix((</>))++-- A glob pattern can contain:+-- * - any number of file name characters, except /+-- ** - any number of file name characters+-- X - anything else is a character that just matches itself+type GlobPattern = String++{-+glob :: GlobPattern -> [String] -> [String]+glob p ss =+ let r = globToRegex p+ in filter (regexMatch r) ss+-}++globToRegex :: GlobPattern -> Regex+globToRegex [] = eps+globToRegex ('*':'*':cs) = Star (Lit (Neg "")) `Seq` globToRegex cs+globToRegex ('*':cs) = Star (Lit (Neg "/")) `Seq` globToRegex cs+globToRegex (c:cs) = Lit (Pos [c]) `Seq` globToRegex cs++-- Recursively find all files in the given directory.+listDirectoryRecursive :: FilePath -> IO [FilePath]+listDirectoryRecursive ".git" = return [] -- Hack to avoid the gazillion files in .git/+listDirectoryRecursive x = do+ xs <- listDirectory x `catch` (\ (_ :: SomeException) -> return [])+ concat <$> (forM xs $ \ y -> (y:) <$> fmap (y </>) <$> listDirectoryRecursive (x </> y))++matchFiles :: FilePath -> [GlobPattern] -> IO [FilePath]+matchFiles dir pats = do+ fs <- listDirectoryRecursive dir+ let select pat =+ let re = globToRegex pat+ in filter (regexMatch re) fs+ pure $ concatMap select pats
src/MicroCabal/Main.hs view
@@ -12,6 +12,7 @@ import MicroCabal.Backend.MHS import MicroCabal.Cabal import MicroCabal.Env+import MicroCabal.Glob import MicroCabal.Normalize import MicroCabal.Parse import MicroCabal.StackageList@@ -19,7 +20,7 @@ --import MicroCabal.YAML version :: String-version = "MicroCabal 0.1.1.0"+version = "MicroCabal 0.2.1.0" main :: IO () main = do@@ -41,16 +42,18 @@ setupEnv = do home <- getEnv "HOME" let cdir = home </> ".mcabal"- return Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, depth = 0,- backend = mhsBackend, recursive = False, targets = [TgtLib, TgtExe] }+ env = Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, depth = 0,+ backend = undefined, recursive = False, targets = [TgtLib, TgtExe] }+ be <- mhsBackend env+ return env{ backend = be } 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 ("--ghc" : as) = do be <- ghcBackend env; loop e{ backend = be } as+ loop e ("--mhs" : as) = do be <- mhsBackend env; loop e{ backend = be } as loop e as = return (e, as) loop env =<< getArgs @@ -140,8 +143,10 @@ -- XXX more... distPkgs :: [StackagePackage] distPkgs =- [ StackagePackage "containers" (makeVersion [0,6,8]) False []- , StackagePackage "mtl" (makeVersion [2,3,1]) False []+ [ StackagePackage "containers" (makeVersion [0,6,8]) False []+ , StackagePackage "deepseq" (makeVersion [1,5,0,0]) False []+ , StackagePackage "mtl" (makeVersion [2,3,1]) False []+ , StackagePackage "time" (makeVersion [1,12,2]) False [] ] -----------------------------------------@@ -218,21 +223,25 @@ getGlobal (Cabal sects) = fromMaybe (error "no global section") $ listToMaybe [ s | s@(Section "global" _ _) <- sects ] -createPathFile :: Env -> Section -> IO ()-createPathFile env (Section _ name _) = do+createPathFile :: Env -> Section -> Section -> IO ()+createPathFile env (Section _ _ glob) (Section _ name _) = do let mdlName = "Paths_" ++ map (\ c -> if c == '-' then '_' else c) name- pathName = pathModuleDir </> mdlName ++ ".hs"+ pathName = pathModuleDir env </> mdlName ++ ".hs"+ vers = getVersion glob "version"+-- dataDir = "???" -- cabalDir env </> "COMPILER-VERSION" </> "data" </> pkgVers </> "data" message env 1 $ "Creating path module " ++ pathName- mkdir env pathModuleDir+ mkdir env (pathModuleDir env) writeFile pathName $ "module " ++ mdlName ++ " where\n" ++- "-- nothing yet\n"+ "import Data.Version\n" +++ "version :: Version; version = make" ++ show vers ++ "\n"+-- ++ "getDataDir :: IO FilePath; getDataDir = return " ++ show dataDir ++ "\n" build :: Env -> IO () build env = do fn <- findCabalFile env rfile <- readFile fn- comp <- backendNameVers (backend env) env+ let comp = backendNameVers (backend env) let cbl = parseCabal fn rfile info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp } ncbl@(Cabal sects) = normalize info cbl@@ -245,7 +254,7 @@ buildExe :: Env -> Section -> Section -> IO () buildExe env glob sect@(Section _ name flds) = do message env 0 $ "Building executable " ++ name- createPathFile env sect+ createPathFile env glob sect let deps = getBuildDepends flds pkgs = [ p | (p, _, _) <- deps ] mapM_ (checkDep env) pkgs@@ -254,7 +263,7 @@ buildLib :: Env -> Section -> Section -> IO () buildLib env glob sect@(Section _ name flds) = do message env 0 $ "Building library " ++ name- createPathFile env sect+ createPathFile env glob sect let pkgs = getBuildDependsPkg flds mapM_ (checkDep env) pkgs buildPkgLib (backend env) env glob sect@@ -292,7 +301,7 @@ install env = do fn <- findCabalFile env rfile <- readFile fn- comp <- backendNameVers (backend env) env+ let comp = backendNameVers (backend env) let cbl = parseCabal fn rfile info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp } ncbl@(Cabal sects) = normalize info cbl@@ -315,9 +324,14 @@ installPkgLib (backend env) env glob sect installDataFiles :: Env -> Section -> Section -> IO ()-installDataFiles _env _glob _sect@(Section _ _ _flds) = do- -- Not yet- return ()+installDataFiles env _glob _sect@(Section _ _ flds) = do+ case getFieldStrings flds [] "data-files" of+ [] -> return ()+ pats -> do+ files <- matchFiles "." pats+ message env 1 $ "Installing data files " ++ unwords files+ let tgt = undefined+ copyFiles env "." files tgt ----------------------------------------- @@ -333,6 +347,7 @@ \ mcabal [FLAGS] update retrieve new set of consistent packages\n\ \\n\ \Flags:\n\+ \ --version show version\n\ \ -v be more verbose (can be repeated)\n\ \ -q be quiet\n\ \ -r do recursive installs for missing packages\n\@@ -351,7 +366,7 @@ cmdParse :: Env -> [String] -> IO () cmdParse env [fn] = do rfile <- readFile fn- comp <- backendNameVers (backend env) env+ let comp = backendNameVers (backend env) let cbl = parseCabal fn rfile info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = comp } ncbl = normalize info cbl
src/MicroCabal/Parse.hs view
@@ -47,6 +47,11 @@ loop _ ('\r':cs) = loop 0 cs loop n ('\t':cs) = replicate k ' ' ++ loop 0 cs where k = 8 - n `rem` 8+ -- Remove '--MHS'.+ -- Hackage does not recognize mhs as a valid compiler yet.+ -- Work around this by having mhs stuff in comments that+ -- MicroCabal ignores.+ loop 0 ('-':'-':'M':'H':'S':cs) = loop 0 cs loop n (c:cs) = c : loop (n+1) cs ------------------------------@@ -411,7 +416,7 @@ , "description" # pFreeText , "extra-doc-files" # pVOptComma , "extra-source-files" # pVOptComma- , "extra-tmp-files" # pVComma+ , "extra-tmp-files" # pVOptComma , "homepage" # pFreeText , "license" # pFreeText , "license-file" # pVOptComma
+ src/MicroCabal/Regex.hs view
@@ -0,0 +1,101 @@+-- Originally stolen from https://crypto.stanford.edu/~blynn/haskell/re.html++-- Regular expression matching using Brzozowski's algorithm+module MicroCabal.Regex(CharClass(..), Regex(..), eps, regexMatch) where+import Data.List(sort, nub)++data CharClass = Pos String | Neg String+ deriving (Eq, Ord, Show)++elemCC :: Char -> CharClass -> Bool+elemCC c (Pos cs) = c `elem` cs+elemCC c (Neg cs) = c `notElem` cs++data Regex+ = Lit CharClass+ | Seq Regex Regex+ | Star Regex+ | Or [Regex]+ | And [Regex]+ | Not Regex+ deriving (Eq, Ord, Show)++regexMatch :: Regex -> String -> Bool+regexMatch re "" = nullable re+regexMatch re (c:s) = regexMatch (derive c re) s++-- The regex `()`. The language containing only the empty string.+eps :: Regex+eps = Star noGood++-- The regex `[]`. The empty language.+noGood :: Regex+noGood = Lit $ Pos []++-- The regex `.*`. The language containing everything.+allGood :: Regex+allGood = Star $ Lit $ Neg []++nullable :: Regex -> Bool+nullable re =+ case re of+ Lit _ -> False+ Star _ -> True+ Seq r s -> nullable r && nullable s+ Or rs -> any nullable rs+ And rs -> all nullable rs+ Not r -> not $ nullable r++derive :: Char -> Regex -> Regex+derive c re =+ case re of+ Lit cc | elemCC c cc -> eps+ | otherwise -> noGood+ Star r -> derive c r `mkSeq` mkStar r+ r `Seq` s | nullable r -> mkOr [derive c r `mkSeq` s, derive c s]+ | otherwise -> derive c r `mkSeq` s+ And rs -> mkAnd $ map (derive c) rs+ Or rs -> mkOr $ map (derive c) rs+ Not r -> mkNot $ derive c r++-- Smart constructors+mkSeq :: Regex -> Regex -> Regex+mkSeq r s+ | r == noGood || s == noGood = noGood+ | r == eps = s+ | s == eps = r+ | x `Seq` y <- r = x `mkSeq` (y `mkSeq` s)+ | otherwise = r `Seq` s++mkOr :: [Regex] -> Regex+mkOr xs+ | allGood `elem` zs = allGood+ | null zs = noGood+ | [z] <- zs = z+ | otherwise = Or zs+ where+ zs = nub $ sort $ filter (/= noGood) flat+ flat = concatMap deOr xs+ deOr (Or rs) = rs+ deOr r = [r]++mkAnd :: [Regex] -> Regex+mkAnd xs+ | noGood `elem` zs = noGood+ | null zs = allGood+ | [z] <- zs = z+ | otherwise = And zs+ where+ zs = nub $ sort $ filter (/= allGood) flat+ flat = concatMap deAnd xs+ deAnd (And rs) = rs+ deAnd r = [r]++mkStar :: Regex -> Regex+mkStar (Star s) = mkStar s+mkStar r = Star r++mkNot :: Regex -> Regex+mkNot (Lit (Pos [])) = allGood+mkNot (Not s) = s+mkNot r = Not r