diff --git a/MicroCabal.cabal b/MicroCabal.cabal --- a/MicroCabal.cabal +++ b/MicroCabal.cabal @@ -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 diff --git a/src/MicroCabal/Backend/GHC.hs b/src/MicroCabal/Backend/GHC.hs --- a/src/MicroCabal/Backend/GHC.hs +++ b/src/MicroCabal/Backend/GHC.hs @@ -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 ++ diff --git a/src/MicroCabal/Backend/MHS.hs b/src/MicroCabal/Backend/MHS.hs --- a/src/MicroCabal/Backend/MHS.hs +++ b/src/MicroCabal/Backend/MHS.hs @@ -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" diff --git a/src/MicroCabal/Cabal.hs b/src/MicroCabal/Cabal.hs --- a/src/MicroCabal/Cabal.hs +++ b/src/MicroCabal/Cabal.hs @@ -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" diff --git a/src/MicroCabal/Env.hs b/src/MicroCabal/Env.hs --- a/src/MicroCabal/Env.hs +++ b/src/MicroCabal/Env.hs @@ -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" diff --git a/src/MicroCabal/Glob.hs b/src/MicroCabal/Glob.hs new file mode 100644 --- /dev/null +++ b/src/MicroCabal/Glob.hs @@ -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 diff --git a/src/MicroCabal/Main.hs b/src/MicroCabal/Main.hs --- a/src/MicroCabal/Main.hs +++ b/src/MicroCabal/Main.hs @@ -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 diff --git a/src/MicroCabal/Parse.hs b/src/MicroCabal/Parse.hs --- a/src/MicroCabal/Parse.hs +++ b/src/MicroCabal/Parse.hs @@ -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 diff --git a/src/MicroCabal/Regex.hs b/src/MicroCabal/Regex.hs new file mode 100644 --- /dev/null +++ b/src/MicroCabal/Regex.hs @@ -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