diff --git a/MicroCabal.cabal b/MicroCabal.cabal --- a/MicroCabal.cabal +++ b/MicroCabal.cabal @@ -1,10 +1,11 @@ cabal-version: 3.0 name: MicroCabal -version: 0.3.1.2 +version: 0.5.10.0 + -- Update src/MicroCabal/Main.hs with version synopsis: A partial Cabal replacement license: Apache-2.0 license-file: LICENSE -copyright: 2024 Lennart Augustsson +copyright: 2024-2026 Lennart Augustsson category: language author: lennart@augustsson.net maintainer: lennart@augustsson.net @@ -45,4 +46,4 @@ directory >= 1.3 && < 1.6, process >= 1.6 && < 1.9, if impl(mhs) - build-depends: base >= 0.1 && < 10.0, + build-depends: base >= 0.1 && < 99.9, 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 @@ -1,20 +1,24 @@ module MicroCabal.Backend.GHC(ghcBackend) where import Control.Monad import Data.List +import Data.Maybe import Data.Version import System.Directory import MicroCabal.Cabal import MicroCabal.Env -import MicroCabal.Macros -import MicroCabal.Parse(readVersion) +--import MicroCabal.Macros +import MicroCabal.StackageList(readVersion) import MicroCabal.Unix +import System.Environment ghcBackend :: Env -> IO Backend ghcBackend env = do + mghc <- lookupEnv "GHC" + let exe = fromMaybe "ghc" mghc -- Actual GHC version. - numVersion <- takeWhile (/= '\n') <$> cmdOut env "ghc --numeric-version" + numVersion <- takeWhile (/= '\n') <$> cmdOut env (exe ++ " --numeric-version") -- GHC version used in the stackage snapshot. - snapVersion <- readFile (cabalDir env "ghc-version") + snapVersion <- readFile (instDir env "ghc-version") let ghcVersion = "ghc-" ++ numVersion version = readVersion numVersion -- Check that the ghc version is the one that the Stackage snapshot wants. @@ -25,9 +29,13 @@ compilerName = "ghc", compilerVersion = version, compiler = ghcVersion, + compilerExe = exe, doesPkgExist = ghcExists, + patchDepends = \ _ x -> x, + patchName = \ _ x -> x, buildPkgExe = ghcBuildExe, buildPkgLib = ghcBuildLib, + buildPkgForLib = ghcBuildForeignLib, installPkgExe = ghcInstallExe, installPkgLib = ghcInstallLib } @@ -36,12 +44,12 @@ getGhcName env = return $ compiler $ backend env getGhcDir :: Env -> IO FilePath -getGhcDir env = (cabalDir env ) <$> getGhcName env +getGhcDir env = (instDir env ) <$> getGhcName env getBuildDir :: Env -> IO FilePath getBuildDir env = do - ghc <- getGhcName env - return $ distDir env "build" ghc + ghcName <- getGhcName env + return $ distDir env "build" ghcName initDB :: Env -> IO () initDB env = do @@ -75,8 +83,7 @@ deps = getBuildDependsPkg flds lang = maybe [] (\ s -> ["-X" ++ s]) mlang buildDir <- getBuildDir env - depvers <- mapM (getPackageVersion env) deps - let macros = genPkgVersionMacros (zip deps depvers) + --depvers <- mapM (getPackageVersion env) deps return $ [ "-package-env=-", "-package-db=" ++ db, @@ -89,13 +96,12 @@ lang ++ map ("-package " ++) deps ++ opts ++ - macros ++ cppOpts binGhc :: FilePath binGhc = "bin" "ghc" -ghcBuildExe :: Env -> Section -> Section -> IO () +ghcBuildExe :: Env -> Section -> Section -> IO FilePath ghcBuildExe env _ (Section _ name flds) = do initDB env let mainIs = getFieldString flds "main-is" @@ -107,7 +113,8 @@ 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 + ghc env args + return bin findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath findMainIs _ [] fn = error $ "cannot find " ++ show fn @@ -127,6 +134,9 @@ getOtherModules :: [Field] -> [String] getOtherModules flds = getFieldStrings flds [] "other-modules" +ghcBuildForeignLib :: Env -> Section -> Section -> IO () +ghcBuildForeignLib = error "NotImplemented" + ghcBuildLib :: Env -> Section -> Section -> IO () ghcBuildLib env (Section _ _ glob) (Section _ name flds) = do initDB env @@ -145,12 +155,12 @@ 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 + ghc env args ghcInstallExe :: Env -> Section -> Section -> IO () ghcInstallExe env (Section _ _ _glob) (Section _ name _) = do let bin = distDir env ++ binGhc ++ name - binDir = cabalDir env "bin" + binDir = instDir env "bin" mkdir env binDir cpr env bin (binDir name) @@ -174,9 +184,9 @@ ghcInstallLib env (Section _ _ glob) (Section _ name flds) = do initDB env buildDir <- getBuildDir env - ghc <- getGhcDir env + ghcDir <- getGhcDir env let namever = name ++ "-" ++ showVersion vers - destDir = ghc namever + destDir = ghcDir namever vers = getVersion glob "version" archOut = destDir "libHS" ++ namever ++ "-mcabal.a" mkdir env destDir @@ -215,3 +225,11 @@ quiet = if verbose env > 0 then "" else " >/dev/null" writeFile pkgFn desc cmd env $ "ghc-pkg update --package-db=" ++ db ++ " " ++ pkgFn ++ quiet + +ghc :: Env -> String -> IO () +ghc env args = cmd env $ compilerExe (backend env) ++ " " ++ args + +--ghcOut :: Env -> String -> IO String +--ghcOut env args = cmdOut env $ compilerExe (backend env) ++ " " ++ args + +-- XXX Should do above for ghc-pkg as well. 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,82 +1,91 @@ module MicroCabal.Backend.MHS(mhsBackend) where import Control.Monad -import Data.List(dropWhileEnd, (\\), stripPrefix) +import Data.List((\\), stripPrefix) +import Data.Maybe import Data.Version import System.Directory import MicroCabal.Cabal import MicroCabal.Env import MicroCabal.Macros -import MicroCabal.Parse(readVersion) +import MicroCabal.StackageList(readVersionM, readVersion) import MicroCabal.Unix +import System.Environment +import Debug.Trace mhsBackend :: Env -> IO Backend mhsBackend env = do - numVersion <- takeWhile (/= '\n') <$> cmdOut env "mhs --numeric-version" + mmhs <- lookupEnv "MHS" + let exe = fromMaybe "mhs" mmhs + numVersion <- takeWhile (/= '\n') <$> cmdOut env (exe ++ " --numeric-version") let mhsVersion = "mhs-" ++ numVersion - version = readVersion numVersion + version = readVersion numVersion return Backend { compilerName = "mhs", compilerVersion = version, compiler = mhsVersion, + compilerExe = exe, doesPkgExist = mhsExists, + patchDepends = mhsPatchDepends, + patchName = mhsPatchName, buildPkgExe = mhsBuildExe, buildPkgLib = mhsBuildLib, + buildPkgForLib = mhsBuildForeignLib, installPkgExe = mhsInstallExe, installPkgLib = mhsInstallLib } mhsNameVers :: Env -> IO (String, Version) mhsNameVers env = do - v <- readVersion . takeWhile (/= '\n') <$> cmdOut env "mhs --numeric-version" + v <- readVersion . takeWhile (/= '\n') <$> mhsOut env "--numeric-version" return ("mhs", v) getMhsDir :: Env -> IO FilePath getMhsDir env = do (n, v) <- mhsNameVers env - return $ cabalDir env ++ "/" ++ n ++ "-" ++ showVersion v + return $ instDir env n ++ "-" ++ showVersion v initDB :: Env -> IO () initDB env = do - dir <- getMhsDir env - b <- doesDirectoryExist dir - when (not b) $ do - --cmd env $ "mhs-pkg init " ++ dir - mkdir env (dir "packages") + dir <- ( "packages") <$>getMhsDir env + mkdir env dir +-- Check for existence of a package by doing 'mhs -Lpkg'. mhsExists :: Env -> PackageName -> IO Bool -mhsExists _ pkgname | Just _ <- lookup pkgname builtinPackages = return True -mhsExists env pkgname = do - initDB env - dir <- getMhsDir env - pkgs <- listDirectory $ dir "packages" - return $ any ((== pkgname) . init . dropWhileEnd (/= '-')) pkgs - +mhsExists _ pkgName | Just _ <- lookup pkgName builtinPackages = return True +mhsExists env pkgName = isJust <$> getPackageVersionM env pkgName + -- XXX These packages are part of mhs. --- The version numbers are totally fake. --- The version numbers are from GHC 9.8.2 +-- The version numbers are totally fake; +-- they are from GHC. builtinPackages :: [(String, Version)] builtinPackages = [ - ("array", makeVersion [0,5,6,0]), +-- ("array", makeVersion [0,5,6,0]), has its own package ("base", makeVersion [4,19,1,0]), - ("deepseq", makeVersion [1,5,0,0]), + ("bytestring",makeVersion [0,12,1,0]), + ("deepseq", makeVersion [1,4,4,0]), ("directory", makeVersion [1,3,8,1]), + ("integer-logarithms", makeVersion [1,0,4]), ("hashable", makeVersion [1,0,0,0]), -- very rudimentary ("process", makeVersion [1,6,18,0]), - ("bytestring",makeVersion [0,12,1,0]), - ("text", makeVersion [2,1,1]) + ("text", makeVersion [2,1,1]), + ("stm", makeVersion [2,5,3,0]) ] getPackageVersion :: Env -> String -> IO Version -getPackageVersion _ pkgName | Just v <- lookup pkgName builtinPackages = return v -getPackageVersion env pkgName = do - dir <- getMhsDir env - pkgs <- listDirectory (dir "packages") - let n = pkgName ++ "-" - case [ readVersion vers | p <- pkgs, Just verspkg <- [stripPrefix n p], Just vers <- [stripSuffix ".pkg" verspkg] ] of - [v] -> return v - [] -> error $ "Not installed: " ++ pkgName - _ -> error $ "Multiple version: " ++ pkgName +getPackageVersion env pkgName = + fromMaybe (error $ "Not installed: " ++ pkgName) <$> getPackageVersionM env pkgName +getPackageVersionM :: Env -> String -> IO (Maybe Version) +getPackageVersionM _ pkgName | Just v <- lookup pkgName builtinPackages = return (Just v) +getPackageVersionM env pkgName = do + mdesc <- tryCmdOut env (mhsFlags env ++ " -L" ++ pkgName) + case mdesc of + Nothing -> return Nothing + Just desc -> + case [ v | l <- lines desc, Just sv <- [stripPrefix "version: " l], Just v <- [readVersionM sv] ] of + [v] -> return (Just v) + _ -> error "getPackageVersionM: parse error" + setupStdArgs :: Env -> [Field] -> IO [String] setupStdArgs env flds = do -- db <- getMhsDir env @@ -91,44 +100,50 @@ deps = getBuildDependsPkg flds mhsX = ["CPP"] depvers <- mapM (getPackageVersion env) deps - let macros = genPkgVersionMacros (zip deps depvers) - return $ -- ["-i"] ++ + let macros = genPkgVersionMacros $ revPatchDepends $ zip deps depvers + return $ ["-i"] ++ map ("-i" ++) srcDirs ++ ["-i" ++ pathModuleDir env] ++ map ("-X" ++) exts' ++ map ("-I" ++) incs ++ opts ++ + compOptions env ++ macros ++ cppOpts binMhs :: String binMhs = "bin" "mhs" -mhsBuildExe :: Env -> Section -> Section -> IO () -mhsBuildExe env _ (Section _ name flds) = do +mhsBuildExe :: Env -> Section -> Section -> IO FilePath +mhsBuildExe env (Section _ _ gflds) (Section _ name flds) = do initDB env let mainIs = getFieldString flds "main-is" srcDirs = getFieldStrings flds ["."] "hs-source-dirs" bin = distDir env binMhs name + gcs = getFieldStrings gflds [] "c-sources" + cs = getFieldStrings flds [] "c-sources" + csrc = gcs ++ cs mkdir env $ distDir env binMhs mainIs' <- findMainIs env srcDirs mainIs stdArgs <- setupStdArgs env flds let args = unwords $ stdArgs ++ - ["-a." - ,"-o" ++ bin, mainIs'] - when (verbose env >= 0) $ - putStrLn $ "Build " ++ bin ++ " with mhs" - --putStrLn $ "mhs " ++ args + csrc ++ + ["-z", "-a.","-o" ++ bin, mainIs'] + message env 0 $ "Build " ++ bin ++ " with mhs" mhs env args + return bin +mhsFlags :: Env -> String +mhsFlags env = compilerExe (backend env) ++ maybe "" (\ p -> " -a'" ++ p ++ "'") (pkgPath env) + mhs :: Env -> String -> IO () mhs env args = do let flg = if verbose env == 1 then "-l " else if verbose env > 1 then "-v " else "" - cmd env $ "mhs " ++ flg ++ args + cmd env $ mhsFlags env ++ " " ++ flg ++ args mhsOut :: Env -> String -> IO String mhsOut env args = - cmdOut env $ "mhs " ++ args + cmdOut env $ mhsFlags env ++ " " ++ args findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath findMainIs _ [] fn = error $ "cannot find " ++ show fn @@ -140,33 +155,50 @@ else findMainIs env ds fn +mhsBuildForeignLib :: Env -> Section -> Section -> IO () +mhsBuildForeignLib env (Section _ _ glob) (Section _ name flds) = do + initDB env + stdArgs <- setupStdArgs env flds + let omdls = getFieldStrings flds (error "no other-modules") "other-modules" + vers = getVersion glob "version" + namever = name ++ "-" ++ showVersion vers + pkgfn = distDir env "lib" ++ namever ++ ".so" + args = unwords $ ["-c", "-optc", "--shared", "-optc", "-fPIC", "-o" ++ pkgfn] ++ stdArgs ++ omdls + mhs env args + mhsBuildLib :: Env -> Section -> Section -> IO () mhsBuildLib env (Section _ _ glob) (Section _ name flds) = do initDB env stdArgs <- setupStdArgs env flds - let mdls = getFieldStrings flds (error "no exposed-modules") "exposed-modules" + let mdls = getFieldStrings flds [] "exposed-modules" omdls = getFieldStrings flds [] "other-modules" vers = getVersion glob "version" namever = name ++ "-" ++ showVersion vers - pkgfn = namever ++ ".pkg" - args = unwords $ ["-P" ++ namever, + pkgfn = distDir env ++ "/" ++ namever ++ ".pkg" + cs = getFieldStrings flds [] "c-sources" + ldf = getFieldStrings flds [] "extra-libraries" + args = unwords $ map ("-optc " ++) cs ++ + map ("-optl -l" ++) ldf ++ + ["-P" ++ namever, "-o" ++ pkgfn] ++ stdArgs ++ ["-a."] ++ mdls isMdl (' ':_) = True -- Relies on -L output format isMdl _ = False + when (null mdls) $ + message env (-1) "Warning: exposed-modules is empty" mhs env args 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" - mapM_ putStrLn bad + message env (-1) "Warning: package modules not mentioned in exposed-modules nor other-modules" + mapM_ (message env (-1)) bad mhsInstallExe :: Env -> Section -> Section -> IO () mhsInstallExe env (Section _ _ _glob) (Section _ name _) = do let bin = distDir env binMhs name - binDir = cabalDir env "bin" + binDir = instDir env "bin" mkdir env binDir cpr env bin (binDir name) @@ -174,10 +206,42 @@ mhsInstallLib env (Section _ _ glob) (Section _ name _) = do initDB env let vers = getVersion glob "version" - namever = name ++ "-" ++ showVersion vers - mhs env $ "-Q " ++ namever ++ ".pkg" + namever = distDir env ++ "/" ++ name ++ "-" ++ showVersion vers + dir <- getMhsDir env + mhs env $ "-Q " ++ namever ++ ".pkg " ++ dir --- --- XXX -stripSuffix :: String -> String -> Maybe String -stripSuffix suf str = reverse <$> stripPrefix (reverse suf) (reverse str) + +-- Update build-depends for packages that have a special mhs version, also add ghc-compat. +mhsPatchDepends :: Env -> Cabal -> Cabal +mhsPatchDepends env cbl@(Cabal sects) = Cabal (map patchSect sects) + where + patchSect (Section styp sname flds) = Section styp sname (map patchField flds) + patchField (Field "build-depends" (VPkgs ds)) = Field "build-depends" (VPkgs (mhsExtraPkgs cbl ++ map patchDep ds)) + patchField fld = fld + patchDep d@(pkg, xs, _mv) | n /= pkg = (n, xs, Just (VEQ v)) + | otherwise = d + where (n, v) = mhsPatchName env (pkg, undefined) + +-- Add a dependency on ghc-compat +mhsExtraPkgs :: Cabal -> [(Item, [Item], Maybe VersionRange)] +mhsExtraPkgs cbl | forMhs (getCabalName cbl) = [] + | otherwise = [ ("ghc-compat", [], Nothing) ] + where forMhs n = n `elem` ["base", "ghc-compat", "MicroHs", "MicroCabal", "canvhs"] + +mhsPatchName :: Env -> (Name, Version) -> (Name, Version) +mhsPatchName env (n, _) | Just nv <- lookup n mhsPackages = + if verbose env >= 0 then trace ("Changing package " ++ n ++ " to " ++ n ++ "-mhs") nv else nv +mhsPatchName _ nv = nv + +mhsPackages :: [(Name, (Name, Version))] +mhsPackages = + [ ("array", ("array-mhs", makeVersion [0,5,8,0])) + , ("random", ("random-mhs", makeVersion [1,3,2,2])) + ] + +-- Temporary hack: undo dependency patching +revPatchDepends :: [(String, Version)] -> [(String, Version)] +revPatchDepends svs = [(rev s, v) | (s, v) <- svs] + where rev s = fromMaybe s $ lookup s revm + revm = [(r, n) | (n, (r, _)) <- mhsPackages] diff --git a/src/MicroCabal/Cabal.hs b/src/MicroCabal/Cabal.hs --- a/src/MicroCabal/Cabal.hs +++ b/src/MicroCabal/Cabal.hs @@ -11,12 +11,16 @@ Item, FlagInfo(..), showCabal, showSection, + getFieldBool, getFieldString, getFieldStringM, getFieldStrings, getBuildDepends, getBuildDependsPkg, getVersion, + replField, + getSection, + getCabalName, ) where import Data.Maybe import Data.Version @@ -100,8 +104,22 @@ indent s = " " ++ concatMap (\ c -> if c == '\n' then "\n " else [c]) s showSection :: Section -> String -showSection (Section s n fs) = unlines $ (" " ++ s ++ " " ++ n) : map (indent . showField) fs +showSection (Section s n fs) = unlines $ (" " ++ s ++ " " ++ n) : map (indent . showField) fs +getCabalName :: Cabal -> Name +getCabalName cbl = + let Section _ _ flds = getSection cbl "global" + in getFieldString flds "name" + +getSection :: Cabal -> SectionType -> Section +getSection (Cabal sects) ty = head $ [s | s@(Section t _ _) <- sects, t == ty] ++ [error ("no section: " ++ show ty)] + +getFieldBool :: Bool -> [Field] -> FieldName -> Bool +getFieldBool dflt flds name = + case [ b | Field n (VBool b) <- flds, n == name ] of + [b] -> b + _ -> dflt + getFieldString :: [Field] -> FieldName -> String getFieldString flds n = fromMaybe (error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)) $ @@ -133,3 +151,12 @@ case [ s | Field f (VVersion s) <- flds, f == n ] of [s] -> s _ -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds) + +dropField :: FieldName -> [Field] -> [Field] +dropField n = filter (\ (Field f _) -> f /= n) + +addField :: FieldName -> Value -> [Field] -> [Field] +addField n v fs = Field n v : fs + +replField :: FieldName -> Value -> [Field] -> [Field] +replField n v = addField n v . dropField n diff --git a/src/MicroCabal/Env.hs b/src/MicroCabal/Env.hs --- a/src/MicroCabal/Env.hs +++ b/src/MicroCabal/Env.hs @@ -11,34 +11,50 @@ import MicroCabal.StackageList(PackageName) data Env = Env { - 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 + instDir :: FilePath, -- where to install, default is $HOME/.mcabal + distDir :: FilePath, -- where to build, default is dist-mcabal + pkgPath :: Maybe String, -- package lookup path + 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 + dryRun :: Bool, -- don't execute commands + useNightly :: Bool, -- use nightly snapshot instead of latest LTS version + eflags :: [(String, Bool)], -- Cabal flags + backend :: Backend, -- which compiler to use, default is MHS + targets :: [Target], -- only build/install these + gitRepo :: Maybe String, -- use git repo for package + gitRef :: Maybe String, -- use git ref when cloning 'gitRepo' + subDir :: Maybe String, -- subdirectory of git repo + compOptions:: [String] -- extra compiler options } + deriving (Show) -data Target = TgtLib | TgtExe - deriving (Eq) +data Target = TgtLib | TgtFor | TgtExe | TgtTst + deriving (Eq, Show) data Backend = Backend { 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" + compilerExe :: String, -- name of binary doesPkgExist :: Env -> PackageName -> IO Bool, -- is the package available in the database? - buildPkgExe :: Env -> Section -> Section -> IO (), -- build executable the current directory + patchDepends :: Env -> Cabal -> Cabal, -- patch dependencies + patchName :: Env -> (Name, Version) -> (Name, Version), -- patch package name + buildPkgExe :: Env -> Section -> Section -> IO FilePath, -- build executable the current directory buildPkgLib :: Env -> Section -> Section -> IO (), -- build the package in the current directory + buildPkgForLib :: Env -> Section -> Section -> IO (), -- build the foreign-library 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 } +instance Show Backend where + show b = "Backend-" ++ compiler b + 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 +message env level msg | verbose env >= level = putStrLn $ "mcabal: " ++ replicate (2 * depth env) ' ' ++ msg | otherwise = return () pathModuleDir :: Env -> FilePath diff --git a/src/MicroCabal/Main.hs b/src/MicroCabal/Main.hs --- a/src/MicroCabal/Main.hs +++ b/src/MicroCabal/Main.hs @@ -7,7 +7,7 @@ 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 @@ -19,23 +19,28 @@ import MicroCabal.Unix --import MicroCabal.YAML +-- Update cabal file when this changes version :: String -version = "MicroCabal 0.3.1.2" +version = "MicroCabal 0.5.10.0" main :: IO () main = do (env, args) <- decodeCommonArgs =<< setupEnv + when (verbose env > 0) $ + putStrLn $ "Env=" ++ show env + case args of [] -> usage ["--version"] -> putStrLn version - "build" : as -> cmdBuild env as - "clean" : as -> cmdClean env as - "fetch" : as -> cmdFetch env as - "help" : as -> cmdHelp env as - "install" : as -> cmdInstall env as - "parse" : as -> cmdParse env as - "update" : as -> cmdUpdate env as + "build" : as -> decodeGit cmdBuild env as + "test" : as -> cmdTest env as + "clean" : as -> cmdClean env as + "fetch" : as -> decodeGit cmdFetch env as + "help" : as -> cmdHelp env as + "install" : as -> decodeGit cmdInstall env as + "parse" : as -> cmdParse env as + "update" : as -> cmdUpdate env as _ -> usage setupEnv :: IO Env @@ -43,21 +48,38 @@ cdirm <- lookupEnv "CABALDIR" home <- getEnv "HOME" let cdir = fromMaybe (home ".mcabal") cdirm - env = Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, depth = 0, - backend = undefined, recursive = False, targets = [TgtLib, TgtExe] } + env = Env{ instDir = cdir, distDir = "dist-mcabal", pkgPath = Nothing, verbose = 0, depth = 0, eflags = [], + backend = error "backend undefined", recursive = False, targets = [TgtLib, TgtFor, TgtExe], + gitRepo = Nothing, gitRef = Nothing, dryRun = False, useNightly = True, subDir = Nothing, compOptions = [] } 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) = do be <- ghcBackend env; loop e{ backend = be } as - loop e ("--mhs" : as) = do be <- mhsBackend env; loop e{ backend = be } as + 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 (('-':'f':s) : as) = loop e{ eflags = decodeCabalFlags s ++ eflags e } as + loop e (('-':'C':s) : as) = loop e{ instDir = s } as + loop e ("-a" : as) = loop e{ pkgPath = Nothing } as + loop e (('-':'a':s) : as) = loop e{ pkgPath = Just $ maybe s (++ (':' : s)) (pkgPath e) } 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 ("--dry-run" : as) = loop e{ dryRun = True } as + loop e ("--nightly" : as) = loop e{ useNightly = True } as + loop e ("--no-nightly" : as) = loop e{ useNightly = False } as + loop e (a : as) | Just r <- stripPrefix "--options=" a + = loop e{ compOptions = compOptions e ++ [r] } as + | Just r <- stripPrefix "--install=" a + = loop e{ instDir = r } as loop e as = return (e, as) loop env =<< getArgs +decodeCabalFlags :: String -> [(Name, Bool)] +decodeCabalFlags = map f . words + where f ('-':s) = (s, False) + f s = (s, True) + usage :: IO () usage = do env <- setupEnv @@ -94,25 +116,26 @@ getBestStackage :: Env -> IO URL getBestStackage env = do -- Get source list - let dir = cabalDir env + let dir = instDir env 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 - 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 + (snap, snap') = + if useNightly env then + -- Pick nightly snapshot + let asnap = fromMaybe (error "no nightly snapshot found") $ lookup nightlyName snaps + fixLeading0 ('/':'0':cs) = '/' : fixLeading0 cs + fixLeading0 (c:cs) = c : fixLeading0 cs + fixLeading0 cs = cs + in (asnap, fixLeading0 $ map (\ c -> if c == '-' then '/' else c) asnap) + else + -- Pick LTS snapshot + let asnap = snd $ last $ + [(0::Int, error "no lts snapshots found")] ++ + sort [ (l, r) | (lp, r) <- snaps, Just l <- [stripPrefix "lts-" lp >>= readMaybe] ] + in (asnap, map (\ c -> if c == '-' || c == '.' then '/' else c) asnap) + snapURL = URL $ snapshotSource ++ snap' ++ ".yaml" message env 1 $ "Picking Stackage snapshot " ++ snap return $ snapURL @@ -120,21 +143,23 @@ cmdUpdate :: Env -> [String] -> IO () cmdUpdate env [] = do message env 0 "Retrieving Stackage package list" - let dir = cabalDir env + let dir = instDir env stk = dir snapshotName fpkgs = dir packageListName mkdir env dir url <- getBestStackage env wget env url stk file <- readFile stk + dist <- getDistPkgs let yml = parseYAML stk file - pkgs = yamlToStackageList yml + pkgs = map hackName $ yamlToStackageList yml ++ dist ghcVersion = yamlToGHCVersion yml + hackName s = s{ stName = n, stVersion = v } where (n, v) = patchName (backend env) env (stName s, stVersion s) -- putStrLn $ "==== " ++ ghcVersion -- putStrLn $ showYAML yml -- putStrLn $ show pkgs message env 1 $ "Write package list to " ++ fpkgs - writeFile fpkgs $ unlines $ map showPackage $ pkgs ++ distPkgs + writeFile fpkgs $ unlines $ map showPackage pkgs writeFile (dir "ghc-version") ghcVersion cmdUpdate _ _ = usage @@ -143,13 +168,30 @@ -- XXX What to do about versions? -- XXX more... -- Should get these from global-hints (?) +-- https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml +getDistPkgs :: IO [StackagePackage] +getDistPkgs = return distPkgs + distPkgs :: [StackagePackage] distPkgs = - [ 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 [] - , StackagePackage "transformers" (makeVersion [0,6,1,2]) False [] + [ StackagePackage "array" (makeVersion [0,5,8,0]) False [] + , StackagePackage "binary" (makeVersion [0,8,9,3]) False [] + , StackagePackage "containers" (makeVersion [0,8]) False [] +-- , StackagePackage "deepseq" (makeVersion [1,6,0,0]) False [] -- built in + , StackagePackage "exceptions" (makeVersion [0,10,11]) False [] + , StackagePackage "filepath" (makeVersion [1,5,5,0]) False [] + , StackagePackage "ghc-compat" (makeVersion [0,5,10,0]) False [] + , StackagePackage "mtl" (makeVersion [2,3,2]) False [] + , StackagePackage "os-string" (makeVersion [2,0,10]) False [] + , StackagePackage "parsec" (makeVersion [3,1,18,0]) False [] + , StackagePackage "pretty" (makeVersion [1,1,3,6]) False [] + , StackagePackage "terminfo" (makeVersion [0,4,1,7]) False [] + , StackagePackage "time" (makeVersion [1,15]) False [] + , StackagePackage "transformers" (makeVersion [0,6,2,0]) False [] + , StackagePackage "unix" (makeVersion [2,8,7,0]) False [] + , StackagePackage "xhtml" (makeVersion [3000,2,2,1]) False [] +-- + , StackagePackage "canvhs" (makeVersion [0,2,0,1]) False [] ] ----------------------------------------- @@ -159,7 +201,7 @@ getPackageList :: Env -> IO [StackagePackage] getPackageList env = do - let dir = cabalDir env + let dir = instDir env fpkgs = dir packageListName b <- doesFileExist fpkgs when (not b) $ do @@ -173,7 +215,7 @@ return $ fromMaybe (error $ "getPackageInfo: no package " ++ pkg) $ listToMaybe $ filter ((== pkg) . stName) pkgs dirPackage :: Env -> FilePath -dirPackage env = cabalDir env "packages" +dirPackage env = instDir env "packages" dirForPackage :: Env -> StackagePackage -> FilePath dirForPackage env st = dirPackage env stName st ++ "-" ++ showVersion (stVersion st) @@ -186,15 +228,20 @@ pkgz = pkgs ++ ".tar.gz" pdir = dirForPackage env st file = pdir ++ ".tar.gz" - b <- doesDirectoryExist pdir - if b then - message env 1 $ "Already in " ++ pdir - else do - mkdir env pdir - message env 1 $ "Fetching " ++ pkgz - wget env url file - message env 1 $ "Unpacking " ++ pkgz ++ " in " ++ pdir - tarx env (dirPackage env) file + rmrf env pdir -- remove existing directory + case gitRepo env of + Nothing -> do + -- Doing a regular hackage fetch. + message env 1 $ "Fetching from Hackage " ++ pkgz + mkdir env pdir + wget env url file + message env 1 $ "Unpacking " ++ pkgz ++ " in " ++ pdir + tarx env (dirPackage env) file + Just repo -> do + -- Doing a git fetch. + -- With --git we will always fetch, blowing away the old repo. + message env 1 $ "Fetching from git repo " ++ repo + gitClone env pdir (URL repo) (GitRef <$> gitRef env) cmdFetch _ _ = usage ----------------------------------------- @@ -205,41 +252,48 @@ case filter (".cabal" `isSuffixOf`) ns of [] -> error "no PKG.cabal file" [n] -> return n - _ -> error "multiple PKG.cabal file" + xs -> error $ "multiple PKG.cabal files: " ++ show xs cmdBuild :: Env -> [String] -> IO () cmdBuild env [] = build env -cmdBuild env [pkg] = do +cmdBuild env [apkg] = do + let pkg = fst $ patchName (backend env) env (apkg, undefined) message env 0 $ "Build package " ++ pkg st <- getPackageInfo env pkg let dir = dirForPackage env st b <- doesDirectoryExist dir - when (not b) $ do - message env 0 $ "Package not found, running 'fetch " ++ pkg ++ "'" + when (not b || isJust (gitRepo env)) $ do + message env 0 $ "Running 'fetch " ++ pkg ++ "'" cmdFetch env [pkg] message env 0 $ "Building in " ++ dir - setCurrentDirectory dir + let dir' = maybe dir (dir ) (subDir env) + setCurrentDirectory dir' cmdBuild env [] cmdBuild _ _ = usage +cmdTest :: Env -> [String] -> IO () +cmdTest env [] = build env { targets = TgtTst : targets env } +cmdTest _ _ = usage + getGlobal :: Cabal -> Section getGlobal (Cabal sects) = fromMaybe (error "no global section") $ listToMaybe [ s | s@(Section "global" _ _) <- sects ] -makeDataPrefix :: Env -> Section -> Section -> FilePath -makeDataPrefix env (Section _ _ glob) (Section _ name _) = - let vers = getVersion glob "version" +makeDataPrefix :: Env -> Section -> FilePath +makeDataPrefix env (Section _ _ glob) = + let name = getFieldString glob "name" + vers = getVersion glob "version" pkgVers = name ++ "-" ++ showVersion vers - dataPrefix = cabalDir env compiler (backend env) "data" pkgVers + dataPrefix = instDir env compiler (backend env) "packages" pkgVers in dataPrefix -createPathFile :: Env -> Section -> Section -> IO () -createPathFile env gsect@(Section _ _ glob) sect = do +createPathFile :: Env -> Section -> IO () +createPathFile env gsect@(Section _ _ glob) = do let vers = getVersion glob "version" name = getFieldString glob "name" mdlName = "Paths_" ++ map (\ c -> if c == '-' then '_' else c) name pathName = pathModuleDir env mdlName ++ ".hs" - dataPrefix = makeDataPrefix env gsect sect + dataPrefix = makeDataPrefix env gsect dataDir = dataPrefix "data" message env 1 $ "Creating path module " ++ pathName mkdir env (pathModuleDir env) @@ -247,7 +301,8 @@ "module " ++ mdlName ++ " where\n" ++ "import Data.Version\n" ++ "version :: Version; version = makeVersion " ++ show (versionBranch vers) ++ "\n" ++ - "getDataDir :: IO FilePath; getDataDir = return " ++ show dataDir ++ "\n" + "getDataDir :: IO FilePath; getDataDir = return " ++ show dataDir ++ "\n" ++ + "getDataFileName :: FilePath -> IO FilePath; getDataFileName name = fmap (++ '/' : name) getDataDir\n" build :: Env -> IO () build env = do @@ -255,32 +310,71 @@ rfile <- readFile fn 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 + info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } + ncbl@(Cabal sects) = normalizeAndPatch env info cbl glob = getGlobal ncbl - 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 () + sectLib s@(Section "library" _ _) | TgtLib `elem` targets env && isBuildable s = buildLib env glob s + sectLib s@(Section "foreign-library" _ _) | TgtFor `elem` targets env && isBuildable s = buildForeignLib env glob s + sectLib _ = return Nothing + sectExe ll s@(Section "executable" _ _) | TgtExe `elem` targets env && isBuildable s = void $ buildExe env glob s ll + sectExe _ _ = return () + sectTst ll s@(Section "test-suite" _ _) | TgtTst `elem` targets env && isBuildable s = buildExe env glob s ll >>= cmd env + sectTst _ _ = return () + sects' = addMissing sects + message env 3 $ "Unnormalized Cabal file:\n" ++ show cbl message env 2 $ "Normalized Cabal file:\n" ++ show ncbl - mapM_ sect $ addMissing sects + -- Build libs first, then exes + localLibs <- catMaybes <$> mapM sectLib sects' + mapM_ (sectExe localLibs) sects' + mapM_ (sectTst localLibs) sects' -buildExe :: Env -> Section -> Section -> IO () -buildExe env glob sect@(Section _ name flds) = do +isBuildable :: Section -> Bool +isBuildable (Section _ _ flds) = getFieldBool True flds "buildable" + +buildExe :: Env -> Section -> Section -> [Name] -> IO FilePath +buildExe env glob@(Section _ _ sglob) sect@(Section _ name flds) localLibs = do message env 0 $ "Building executable " ++ name - createPathFile env glob sect + createPathFile env glob let deps = getBuildDepends flds - pkgs = [ p | (p, _, _) <- deps ] + pkgs = [ p | (p, _, _) <- deps, p `notElem` localLibs ] + vers = getVersion sglob "version" + sect' = hackLocalLibs env localLibs vers sect mapM_ (checkDep env) pkgs - buildPkgExe (backend env) env glob sect + buildPkgExe (backend env) env glob sect' -buildLib :: Env -> Section -> Section -> IO () +-- Remove dependencies on locally built libraries and add them +-- as preloads of the mhs-options. +hackLocalLibs :: Env -> [Name] -> Version -> Section -> Section +hackLocalLibs env locals vers (Section stype sname flds) = + Section stype sname $ addLocals $ map removeLocals flds + where removeLocals (Field "build-depends" (VPkgs ps)) = + Field "build-depends" $ VPkgs $ filter (\ (n, _, _) -> n `notElem` locals) ps + removeLocals f = f + addLocals fs = + let mhso = "mhs-options" + mfs = getFieldStrings fs [] mhso + mfs' = VItems (map ("-p" ++) localFiles ++ mfs) + in replField mhso mfs' fs + localFiles = map (\ n -> distDir env ++ "/" ++ n ++ "-" ++ showVersion vers ++ ".pkg") locals + +buildLib :: Env -> Section -> Section -> IO (Maybe Name) buildLib env glob sect@(Section _ name flds) = do message env 0 $ "Building library " ++ name - createPathFile env glob sect + createPathFile env glob let pkgs = getBuildDependsPkg flds mapM_ (checkDep env) pkgs buildPkgLib (backend env) env glob sect + return (Just name) +buildForeignLib :: Env -> Section -> Section -> IO (Maybe Name) +buildForeignLib env glob sect@(Section _ name flds) = do + message env 0 $ "Building foreign-library " ++ name + createPathFile env glob + let pkgs = getBuildDependsPkg flds + mapM_ (checkDep env) pkgs + buildPkgForLib (backend env) env glob sect + return (Just name) + checkDep :: Env -> PackageName -> IO () checkDep env pkg = do let bend = backend env @@ -290,6 +384,7 @@ let env' = env { depth = depth env + 1 } preserveCurrentDirectory $ cmdInstallLib env' [pkg] + message env 0 "Return to building target" else error $ "dependency not installed: " ++ pkg @@ -301,6 +396,12 @@ ----------------------------------------- +decodeGit :: (Env -> [String] -> IO ()) -> Env -> [String] -> IO () +decodeGit io env (arg:args) | repo@(Just _) <- stripPrefix "--git=" arg = decodeGit io (env{ gitRepo = repo }) args +decodeGit io env (arg:args) | ref@(Just _) <- stripPrefix "--git-ref=" arg = decodeGit io (env{ gitRef = ref }) args +decodeGit io env (arg:args) | dir@(Just _) <- stripPrefix "--dir=" arg = decodeGit io (env{ subDir = dir }) args +decodeGit io env args = io env args + cmdInstall :: Env -> [String] -> IO () cmdInstall env args = do -- The will build and change current directory @@ -316,19 +417,20 @@ rfile <- readFile fn 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 + info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } + ncbl@(Cabal sects) = normalizeAndPatch env info cbl glob = getGlobal ncbl - 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 s@(Section "executable" _ _) | TgtExe `elem` targets env && isBuildable s = installExe env glob s + sect s@(Section "library" _ _) | TgtLib `elem` targets env && isBuildable s = installLib env glob s sect _ = return () + message env 3 $ "Unnormalized Cabal file:\n" ++ show cbl message env 2 $ "Normalized Cabal file:\n" ++ show ncbl + installDataFiles env glob mapM_ sect $ addMissing sects installExe :: Env -> Section -> Section -> IO () installExe env glob sect@(Section _ name _) = do message env 0 $ "Installing executable " ++ name - installDataFiles env glob sect installIncludeFiles env glob sect installCFiles env glob sect installPkgExe (backend env) env glob sect @@ -336,49 +438,44 @@ installLib :: Env -> Section -> Section -> IO () installLib env glob sect@(Section _ name _) = do message env 0 $ "Installing library " ++ name - installDataFiles env glob sect installIncludeFiles env glob sect installCFiles env glob sect installPkgLib (backend env) env glob sect -installDataFiles :: Env -> Section -> Section -> IO () -installDataFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do - let gdatas = getFieldStrings gflds [] "data-files" - datas = getFieldStrings flds [] "data-files" - dataPrefix = makeDataPrefix env glob sect - dataDir = dataPrefix "data" - --print ("installDataFiles", gdatas ++ datas, dataDir) - case gdatas ++ datas of +installDataFiles :: Env -> Section -> IO () +installDataFiles env glob@(Section _ _ flds) = do + let datas = getFieldStrings flds [] "data-files" + dataDir = fromMaybe "." (getFieldStringM flds "data-dir") + installDataPrefix = makeDataPrefix env glob + installDataDir = installDataPrefix "data" + files <- matchFiles dataDir datas + case files of [] -> return () - pats -> do - files <- matchFiles "." pats + _ -> do message env 1 $ "Installing data files " ++ unwords files - mkdir env dataDir - copyFiles env "." files dataDir + mkdir env installDataDir + copyFiles env dataDir files installDataDir installIncludeFiles :: Env -> Section -> Section -> IO () -installIncludeFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do - let gincs = getFieldStrings gflds [] "install-includes" - incs = getFieldStrings flds [] "install-includes" - dataPrefix = makeDataPrefix env glob sect +installIncludeFiles env glob (Section _ _ flds) = do + let incs = getFieldStrings flds [] "install-includes" + dataPrefix = makeDataPrefix env glob incDir = dataPrefix "include" - case gincs ++ incs of + inc = head $ getFieldStrings flds ["."] "include-dirs" -- XXX search all dirs + files <- matchFiles inc incs + case files of [] -> return () - pats -> do - let inc = head $ getFieldStrings flds ["."] "include-dirs" - files <- matchFiles inc pats - -- print (pats, files) + _ -> do message env 1 $ "Installing include files " ++ unwords files mkdir env incDir copyFiles env inc files incDir installCFiles :: Env -> Section -> Section -> IO () -installCFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do - let gcs = getFieldStrings gflds [] "c-sources" - cs = getFieldStrings flds [] "c-sources" - dataPrefix = makeDataPrefix env glob sect +installCFiles env glob (Section _ _ flds) = do + let cs = getFieldStrings flds [] "c-sources" + dataPrefix = makeDataPrefix env glob cDir = dataPrefix "cbits" - case gcs ++ cs of + case cs of [] -> return () files -> do message env 1 $ "Installing C files " ++ unwords files @@ -390,23 +487,30 @@ cmdHelp :: Env -> [String] -> IO () 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\ + \ mcabal [FLAGS] build [--git=URL [--gitRef=REF] [--dir=DIR]] [PKG] build in current directory, or the package PKG\n\ + \ mcabal [FLAGS] test build and run tests in current directory\n\ + \ mcabal [FLAGS] clean clean in the current directory\n\ + \ mcabal [FLAGS] fetch [--git=URL [--dir=DIR]] PKG fetch files for package PKG\n\ + \ mcabal [FLAGS] help show this message\n\ + \ mcabal [FLAGS] install [--git=URL [--dir=DIR]] [PKG] build and install in current directory, or the package PKG\n\ + \ mcabal [FLAGS] parse FILE just parse a Cabal file (for debugging)\n\ + \ mcabal [FLAGS] update retrieve new set of consistent packages from Stackage\n\ \\n\ \Flags:\n\ \ --version show version\n\ + \ -fFLAGS set cabal 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\ + \ --git=URL fetch from the Git repo instead of hackage\n\ + \ --dry-run do NOT execute the commands, just print\n\ + \ --no-nightly use latest versioned snapshot from stackage instead of nightly\n\ + \ --options=OPTIONS set compiler options\n\ + \ --install=DIR set the installation directory\n\ \\n\ - \Installs go to $CABALDIR if set, otherwise $HOME/.mcabal.\n\ + \If no directory is given, installs go to $CABALDIR if set, otherwise $HOME/.mcabal.\n\ \" ----------------------------------------- @@ -421,8 +525,13 @@ rfile <- readFile fn 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 - --putStrLn $ showCabal cbl + info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } + ncbl = normalizeAndPatch env info cbl + putStrLn "Unnormalized:" + putStrLn $ showCabal cbl + putStrLn "Normalized:" putStrLn $ showCabal ncbl -cmdParse _ _ = undefined +cmdParse _ _ = error "cmdParse" + +normalizeAndPatch :: Env -> FlagInfo -> Cabal -> Cabal +normalizeAndPatch env flags = patchDepends (backend env) env . normalize flags diff --git a/src/MicroCabal/Normalize.hs b/src/MicroCabal/Normalize.hs --- a/src/MicroCabal/Normalize.hs +++ b/src/MicroCabal/Normalize.hs @@ -1,4 +1,5 @@ module MicroCabal.Normalize(normalize) where +import Data.Char(toLower) import Data.Function import Data.List import Data.Maybe @@ -50,9 +51,9 @@ reduce :: FlagInfo -> Cabal -> Cabal reduce info c = reduce' (addFlags c) c where addFlags (Cabal ss) = info{ flags = flags info ++ concatMap sect ss } - sect (Section "flag" n fs) = [(n, dflt n fs)] + sect (Section "flag" n fs) = [(map toLower n, dflt fs)] sect _ = [] - dflt n fs = head $ [ b | Field "default" (VBool b) <- fs ] ++ [error $ "no default for flag " ++ show n] + dflt fs = head $ [ b | Field "default" (VBool b) <- fs ] ++ [True] reduce' :: FlagInfo -> Cabal -> Cabal reduce' info = mapField red @@ -74,8 +75,14 @@ eval (Cnot a) = not (eval a) eval (Cos s) = os info == s eval (Carch s) = arch info == s - eval (Cflag n) = fromMaybe (error $ "Undefined flag " ++ show n) $ lookup n (flags info) - eval (Cimpl s mv) = n == s && maybe True (inVersionRange v) mv where (n, v) = impl info + eval (Cflag n) = fromMaybe (error $ "Undefined flag " ++ show n) $ lookup (map toLower n) (flags info) + eval (Cimpl s mv) = n == s && maybe True (inVersionRange v) mv + -- Pretend we are ghc >= 9.0. This is an ugly hack, but makes + -- some packages work with no change (change is hard!). + || fromMaybe False (lookup "fake-ghc" (flags info)) && + s == "ghc" && maybe False (inVersionRange hackv) mv + where (n, v) = impl info + hackv = makeVersion [9,6,0] inVersionRange :: Version -> VersionRange -> Bool inVersionRange v (VEQ v') = v == v' diff --git a/src/MicroCabal/Parse.hs b/src/MicroCabal/Parse.hs --- a/src/MicroCabal/Parse.hs +++ b/src/MicroCabal/Parse.hs @@ -2,7 +2,6 @@ parseCabal, parseYAML, parseSnapshots, - readVersion, ) where import Control.Applicative import Control.Monad @@ -19,7 +18,10 @@ parseCabal fn rfile = runP pCabalTop fn $ dropCabalComments rfile parseYAML :: FilePath -> String -> YAMLValue -parseYAML fn rfile = runP pYAMLTop fn $ dropYAMLComments rfile +parseYAML fn s = + case parseYaml s of + Left e -> error $ "YAML parse failed " ++ show fn ++ ": " ++ e + Right y -> y parseSnapshots :: FilePath -> String -> [(String, String)] parseSnapshots fn rfile = runP pSnapshotsTop fn rfile @@ -90,22 +92,18 @@ pushColumn :: P () pushColumn = mapTokenState (\ (LS i ks cs) -> LS i (i:ks) cs) -pushFieldSep :: P () -pushFieldSep = mapTokenState (\ (LS i ks cs) -> LS i ks (fieldSep:cs)) - lower :: String -> String lower = map toLower -- Change lines with first non-space being '--' into just a newline --- Remove '--MHS'. --- Hackage does not recognize mhs as a valid compiler yet. --- Work around this by having mhs stuff in comments that --- MicroCabal ignores. +-- Remove '--MCABAL'. This is because cabal does not allow conditionals +-- for the global section, and mhs needs that. dropCabalComments :: String -> String dropCabalComments = unlines . map cmt . lines where - cmt ('-':'-':'M':'H':'S':cs) = cmt cs + cmt ('-':'-':'M':'C':'A':'B':'A':'L':cs) = cmt cs cmt s | take 2 (dropWhile (== ' ') s) == "--" = "" + | "--NOT_MHS" `isSuffixOf` s = "" | otherwise = s satisfySome :: String -> (Char -> Bool) -> P [Char] @@ -168,11 +166,13 @@ pVersion :: P Version pVersion = pSpaces *> (makeVersion <$> esepBy1 pNumber pDot) +-- A VersionRange can contain newlines. I'm not sure where and how. +-- So, allow it around && and ||. At least it works for containers. pVersionRange :: P VersionRange pVersionRange = pVOr where - pVOr = foldr1 VOr <$> esepBy1 pVAnd (pStr "&&") - pVAnd = foldr1 VAnd <$> esepBy1 pVOp (pStr "||") + pVOr = foldr1 VOr <$> esepBy1 pVAnd (pStrW "||" <* pWhite) + pVAnd = foldr1 VAnd <$> esepBy1 pVOp (pStrW "&&" <* pWhite) pVOp = (pVOper <*> (pSpaces *> pVersion)) <|< pParens pVersionRange <|< (pStr "==" *> pVEq) @@ -234,17 +234,12 @@ where -- sometimes (kan-extensions.cabal) there is a spurious comma, -- so allow that - p' = p <* eoptional (pStr ",") + p' = p <* eoptional (pStrW ",") pOptCommaList :: P a -> P [a] 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) + <|< pSpaceList p pVComma :: P Value pVComma = VItems <$> pCommaList pItem @@ -256,7 +251,7 @@ pVOptComma = VItems <$> pOptCommaList pItem pVLibs :: P Value -pVLibs = VPkgs <$> pCommaList pPkg +pVLibs = VPkgs <$> pOptCommaList pPkg pPkg :: P (Item, [Item], Maybe VersionRange) pPkg = (,,) <$> pNameW <*> (pSpaces *> pLibs) <*> optional pVersionRange @@ -275,20 +270,31 @@ fn <- lower <$> pFieldName -- traceM ("pFieldName fn=" ++ show fn) if fn == "if" then do - c <- pCond + cnd <- pCond pNewLine - t <- emany pField + thn <- emany pField pFieldSep - e <- do + -- some number of elif + elifs <- emany $ do pWhite pushColumn + _ <- pKeyWordNC "elif" + cc <- pCond + pNewLine + tt <- emany pField + pFieldSep + pure (cc, tt) + els <- do + pWhite + pushColumn _ <- pKeyWordNC "else" fs <- emany pField pFieldSep pure fs <|< pure [] - pure $ If c t e + let els' = foldr (\ (cc, tt) ee -> [If cc tt ee]) els elifs + pure $ If cnd thn els' else do pColon -- traceM $ "parser " ++ fn @@ -301,8 +307,8 @@ pCond :: P Cond pCond = pCor where - pCor = foldr1 Cor <$> esepBy1 pCand (pStr "&&") - pCand = foldr1 Cand <$> esepBy1 pCnot (pStr "||") + pCor = foldr1 Cor <$> esepBy1 pCand (pStr "||") + pCand = foldr1 Cand <$> esepBy1 pCnot (pStr "&&") pCnot = (Cnot <$> (pStr "!" *> pCnot)) <|> pCOp pCOp = (CBool <$> pBool) <|< (pKeyWordNC "arch" *> pParens (Carch <$> pName)) @@ -333,6 +339,10 @@ pFields :: P [Field] pFields = pSpaces *> pNewLine *> emany pField +-- Skip initial NL +pBoolNL :: P Bool +pBoolNL = many pNewLine *> pBool + pBool :: P Bool pBool = (False <$ pKeyWordNC "false") <|< (True <$ pKeyWordNC "true") @@ -340,6 +350,7 @@ pSection = pWhite *> ( Section <$> pKeyWordNC "common" <*> pName <*> pFields <|< Section <$> pKeyWordNC "library" <*> libName <*> pFields + <|< Section <$> pKeyWordNC "foreign-library" <*> pName <*> pFields <|< Section <$> pKeyWordNC "executable" <*> pName <*> pFields <|< Section <$> pKeyWordNC "source-repository" <*> pName <*> pFields <|< Section <$> pKeyWordNC "flag" <*> pName <*> pFields @@ -361,18 +372,19 @@ , "autogen-modules" # pVComma , "build-depends" # pVLibs , "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 + , "build-tools" # pVLibs -- XXX + , "buildable" # (VBool <$> pBoolNL) + , "c-sources" # pVOptComma + , "cc-options" # pVOptComma + , "cmm-sources" # pVOptComma + , "cmm-options" # pVOptComma , "cpp-options" # pVOptComma - , "cxx-options" # pVComma + , "cxx-options" # pVOptComma , "default-extensions" # pVOptComma , "default-language" # (VItem <$> pItem) , "exposed-modules" # pVOptComma , "reexported-modules" # pVOptComma + , "exposed" # (VBool <$> pBoolNL) , "extensions" # pVOptComma , "extra-bundled-libraries" # pVComma , "extra-dynamic-library-flavours" # pVComma @@ -380,7 +392,7 @@ , "extra-ghci-libraries" # pVComma , "extra-lib-dirs" # pVComma , "extra-lib-dirs-static" # pVComma - , "extra-libraries" # pVComma + , "extra-libraries" # pVOptComma , "frameworks" # pVOptComma , "ghc-options" # pVSpace , "ghc-prof-options" # pVSpace @@ -395,107 +407,59 @@ , "install-includes" # pVOptComma , "js-sources" # pVComma , "ld-options" # pVSpace + , "mhs-options" # pVSpace , "mixins" # pFreeText -- XXX , "nhc98-options" # pVSpace , "other-extensions" # pVOptComma , "other-languages" # (VItem <$> pItem) , "other-modules" # pVOptComma - , "pkg-config-depends" # pVComma + , "pkgconfig-depends" # pVComma , "virtual-modules" # pVComma - --- library fields + --- library fields , "visibility" # (VItem <$> pItem) - --- package fields + --- foreign-library fields + , "type" # (VItem <$> pItem) + --- package fields , "author" # pFreeText - , "bug-reports" # pFreeText + , "bug-reports" # (VItem <$> pItem) , "build-type" # (VItem <$> pItem) , "cabal-version" # pFreeText -- (VRange <$> pVersionRange) , "category" # pFreeText , "copyright" # pFreeText - , "data-dir" # pVSpace + , "data-dir" # (VItem <$> pItem) , "data-files" # pVOptComma , "description" # pFreeText , "extra-doc-files" # pVOptComma , "extra-source-files" # pVOptComma , "extra-tmp-files" # pVOptComma - , "homepage" # pFreeText - , "license" # pFreeText + , "homepage" # (VItem <$> pItem) + , "license" # (VItem <$> pItem) , "license-file" # pVOptComma , "license-files" # pVOptComma , "maintainer" # pFreeText , "name" # (VItem <$> pItem) - , "package-url" # pFreeText + , "package-url" # (VItem <$> pItem) , "stability" # pFreeText - , "subdir" # pFreeText , "synopsis" # pFreeTextX - , "tested-with" # pFreeText + , "tested-with" # pVLibs , "version" # (VVersion <$> pVersion) - -- test suite fields + -- test suite fields , "main-is" # (VItem <$> pItem) , "test-module" # (VItem <$> pItem) - , "type" # (VItem <$> pItem) -- source-repository fields - , "location" # pFreeText + , "location" # (VItem <$> pItem) + , "module" # (VItem <$> pItem) + , "branch" # (VItem <$> pItem) + , "tag" # (VItem <$> pItem) + , "subdir" # (VItem <$> pItem) -- flag fields - , "manual" # (VBool <$> pBool) - , "default" # (VBool <$> pBool) - , "tag" # pFreeText + , "manual" # (VBool <$> pBoolNL) + , "default" # (VBool <$> pBoolNL) ] - where (#) = (,) + where ( # ) = (,) -- XXX use local fixity - - ----------------------------------------------------------------------- --- XXX Wrong for strings -dropYAMLComments :: String -> String -dropYAMLComments [] = [] -dropYAMLComments (c:cs) | c == '#' = dropYAMLComments (dropWhile (/= '\n') cs) - | otherwise = c : dropYAMLComments cs -pYAMLTop :: P YAMLValue -pYAMLTop = pYAMLRecord <* pWhite <* pChar end - -pYAMLValue :: P YAMLValue -pYAMLValue = - (YBool <$> pBool) - <|< (YInt <$> pNumber) --- <|< (YString <$> pString) - <|< pYAMLArray - <|< pYAMLRecord - <|< (YString <$> pYAMLFree) - -pYAMLArray :: P YAMLValue -pYAMLArray = do - pWhite - let - pElem = pChar '-' *> pSpaces *> pYAMLValue - pElemFS = pWhite *> pElem <* pFieldSep - pElemsFS = esome pElemFS - pElemNL = pElem <* pChar '\n' - pElemsNL = pFieldSep *> pChar '\n' *> esome pElemNL <* pushFieldSep - YArray <$> (pElemsNL <|< pElemsFS) - -pYAMLRecord :: P YAMLValue -pYAMLRecord = YRecord <$> esome pYAMLField - -pYAMLFree :: P String -pYAMLFree = do - pSpaces - d <- nextToken - guard (d /= '-') - txt <- satisfyMany (\ c -> c /= end && c /= fieldSep && c /= '\n') - pure txt - -pYAMLField :: P (YAMLFieldName, YAMLValue) -pYAMLField = do - pWhite - pushColumn - n <- pFieldName - pColon - v <- pYAMLValue - pFieldSep - pure (n, v) - ---------------------------------------------------------------------- type Snapshot = (String, String) @@ -508,8 +472,3 @@ 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) diff --git a/src/MicroCabal/StackageList.hs b/src/MicroCabal/StackageList.hs --- a/src/MicroCabal/StackageList.hs +++ b/src/MicroCabal/StackageList.hs @@ -7,6 +7,7 @@ yamlToStackageList, yamlToGHCVersion, readVersionM, + readVersion, ) where import Data.Maybe import Data.Version @@ -41,7 +42,7 @@ yamlToStackageList (YRecord flds) = let lookf s = fromMaybe (error $ "yamlToStackageList: no " ++ s) $ lookup s flds in case (lookf "flags", lookf "hidden", lookf "packages") of - (YRecord flags, YRecord hidden, YArray packages) -> + (YRecord flags, YRecord hidden, YArray packages) -> map (addFlags flags . addHidden hidden . decodePackage) packages _ -> error "Unrecognized Stackage package list format" yamlToStackageList _ = error "Unrecognized Stackage package list format" @@ -49,19 +50,10 @@ -- 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 + fromMaybe (error "yamlToGHCVersion: no GHC version") $ do + YRecord pflds <- lookup "resolver" flds + YString ver <- lookup "compiler" pflds + return ver yamlToGHCVersion _ = error "Unrecognized Stackage package list format" addFlags :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage diff --git a/src/MicroCabal/Unix.hs b/src/MicroCabal/Unix.hs --- a/src/MicroCabal/Unix.hs +++ b/src/MicroCabal/Unix.hs @@ -1,7 +1,8 @@ module MicroCabal.Unix( cmd, tryCmd, cmdOut, tryCmdOut, mkdir, - wget, URL(..), + wget, URL(..), GitRef(..), + gitClone, tarx, rmrf, cp, cpr, @@ -19,10 +20,15 @@ newtype URL = URL String +newtype GitRef = GitRef String + cmd :: Env -> String -> IO () cmd env s = do message env 2 $ "cmd: " ++ s - callCommand s + if dryRun env then + putStrLn s + else + callCommand s tryCmd :: Env -> String -> IO Bool tryCmd env s = catch (cmd env s >> return True) f @@ -42,7 +48,7 @@ tryCmdOut env s = do (fn, h) <- tmpFile hClose h - b <- tryCmd env $ s ++ " >" ++ fn + b <- tryCmd env $ s ++ " >" ++ fn ++ " 2>/dev/null" if b then do o <- readFile fn removeFile fn @@ -69,7 +75,12 @@ -- Get a document, store it in a file. wget :: Env -> URL -> FilePath -> IO () -wget env (URL url) fn = cmd env $ "wget --quiet --output-document=" ++ fn ++ " " ++ url +wget env (URL url) fn = do + mw <- lookupEnv "MICROCABAL_USE_WGET" + if isNothing mw then + cmd env $ "curl -s -o" ++ fn ++ " " ++ url + else + cmd env $ "wget --quiet --output-document=" ++ fn ++ " " ++ url -- Extract a tar file tarx :: Env -> FilePath -> FilePath -> IO () @@ -88,7 +99,7 @@ cpr :: Env -> FilePath -> FilePath -> IO () cpr env s d = do cmd env $ "rm -f " ++ d - cp env s d + cp env s d copyFiles :: Env -> FilePath -> [FilePath] -> FilePath -> IO () copyFiles env src fns tgt = do @@ -100,6 +111,12 @@ a <- io setCurrentDirectory cwd return a + +gitClone :: Env -> FilePath -> URL -> Maybe GitRef -> IO () +gitClone env dir (URL repo) (Just (GitRef ref)) = + cmd env $ "git clone --depth 1 --branch " ++ ref ++ " --quiet " ++ repo ++ " " ++ dir +gitClone env dir (URL repo) Nothing = + cmd env $ "git clone --depth 1 --quiet " ++ repo ++ " " ++ dir ----- diff --git a/src/MicroCabal/YAML.hs b/src/MicroCabal/YAML.hs --- a/src/MicroCabal/YAML.hs +++ b/src/MicroCabal/YAML.hs @@ -2,7 +2,12 @@ YAMLValue(..), YAMLFieldName, showYAML, + parseYaml, ) where +import Control.Applicative (Alternative(..)) +import Data.Char (isSpace, isAlphaNum) +import Data.List (isPrefixOf) + type YAMLFieldName = String data YAMLValue @@ -11,7 +16,310 @@ | YInt Int | YRecord [(YAMLFieldName, YAMLValue)] | YArray [YAMLValue] + | YNull deriving (Show) showYAML :: YAMLValue -> String showYAML = show + +---------- +-- Code mostly by Claude Sonnet 2.5 +-- Not exactly a work of beauty, but it seems to work. + +newtype Parser a = Parser { runParser :: String -> Either String (a, String) } + +instance Functor Parser where + fmap f (Parser p) = Parser $ \input -> do + (x, rest) <- p input + return (f x, rest) + +instance Applicative Parser where + pure x = Parser $ \input -> Right (x, input) + (Parser pf) <*> (Parser px) = Parser $ \input -> do + (f, rest1) <- pf input + (x, rest2) <- px rest1 + return (f x, rest2) + +instance Monad Parser where + (Parser p) >>= f = Parser $ \input -> do + (x, rest) <- p input + runParser (f x) rest + +instance Alternative Parser where + empty = Parser $ \_ -> Left "empty" + (Parser p1) <|> (Parser p2) = Parser $ \input -> + case p1 input of + Right x -> Right x + Left _ -> p2 input + +-- | Count leading spaces +countSpaces :: String -> Int +countSpaces = length . takeWhile (== ' ') + +-- | Skip to next non-empty, non-comment line and return its indentation +peekIndent :: String -> Maybe Int +peekIndent input = go input + where + go "" = Nothing + go ('\n':rest) = go rest + go s@(' ':_) = + let spaces = countSpaces s + afterSpaces = drop spaces s + in case afterSpaces of + ('#':_) -> go (dropWhile (/= '\n') afterSpaces) + ('\n':_) -> go afterSpaces + "" -> Nothing + _ -> Just spaces + go ('#':rest) = go (dropWhile (/= '\n') rest) + go _ = Just 0 + +-- | Skip spaces (not newlines) +skipSpaces :: Parser () +skipSpaces = Parser $ \input -> Right ((), dropWhile (\c -> c == ' ' || c == '\t') input) + +-- | Skip empty lines and comments +skipEmpty :: Parser () +skipEmpty = Parser go + where + go "" = Right ((), "") + go ('\n':rest) = go rest + go input@(' ':_) = + let afterSpaces = dropWhile (== ' ') input + in case afterSpaces of + ('\n':rest) -> go rest + ('#':_) -> go (dropWhile (/= '\n') afterSpaces) + _ -> Right ((), input) + go input@('#':_) = go (dropWhile (/= '\n') input) + go input = Right ((), input) + +-- | Consume exact spaces +exactSpaces :: Int -> Parser () +exactSpaces n = Parser $ \input -> + let prefix = take n input + in if length prefix == n && all (== ' ') prefix + then Right ((), drop n input) + else Left $ "Expected " ++ show n ++ " spaces at indent, got: " ++ show (countSpaces input) + +-- | Parse a specific character +char :: Char -> Parser Char +char c = Parser $ \input -> case input of + (x:xs) | x == c -> Right (c, xs) + _ -> Left $ "Expected '" ++ [c] ++ "'" + +-- | Parse until predicate is true +takeWhileP :: (Char -> Bool) -> Parser String +takeWhileP prd = Parser $ \input -> + let (taken, rest) = span prd input + in Right (taken, rest) + +-- | Parse a YAML key (alphanumeric, dash, underscore, but not starting with dash alone) +parseKey :: Parser String +parseKey = do + first <- Parser $ \input -> case input of + (c:cs) | isAlphaNum c || c == '_' -> Right (c, cs) + _ -> Left "Expected key character" + rest <- takeWhileP (\c -> isAlphaNum c || c == '_' || c == '-') + return (first:rest) + +-- | Parse the rest of the line (value on same line) +parseLineValue :: Parser String +parseLineValue = Parser $ \input -> + let trimmed = dropWhile (== ' ') input + (value, rest) = break (\c -> c == '\n' || c == '#') trimmed + cleaned = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace value + in if null cleaned + then Left "Empty line value" + else Right (cleaned, rest) + +-- | Parse boolean +parseBool :: String -> Maybe Bool +parseBool "true" = Just True +parseBool "false" = Just False +parseBool _ = Nothing + +-- | Try to parse as integer +parseInt :: String -> Maybe Int +parseInt t = case reads t of + [(n, "")] -> Just n + _ -> Nothing + +-- | Convert text to YAMLValue +textToValue :: String -> YAMLValue +textToValue t + | Just b <- parseBool t = YBool b + | Just n <- parseInt t = YInt n + | t == "null" = YNull + | otherwise = YString t + +-- | Parse value on same line as key +parseInlineValue :: Parser YAMLValue +parseInlineValue = do + val <- parseLineValue + return $ textToValue val + +-- | Parse key-value pair at given indentation +parseKV :: Int -> Parser (String, YAMLValue) +parseKV indent = Parser $ \input -> do + -- Skip empty lines first + ((), afterEmpty) <- runParser skipEmpty input + -- Check indentation + case runParser (exactSpaces indent) afterEmpty of + Left err -> Left $ "parseKV indent error: " ++ err ++ " at: " ++ take 50 afterEmpty + Right ((), afterIndent) -> do + -- Parse key + case runParser parseKey afterIndent of + Left err -> Left $ "parseKV key error: " ++ err ++ " at: " ++ take 50 afterIndent + Right (key, afterKey) -> do + -- Skip spaces + ((), afterSpaces) <- runParser skipSpaces afterKey + -- Expect colon + case runParser (char ':') afterSpaces of + Left err -> Left $ "parseKV colon error at key '" ++ key ++ "': " ++ err ++ " at: " ++ take 50 afterSpaces + Right (_, afterColon) -> do + -- Skip spaces after colon + ((), afterColonSpaces) <- runParser skipSpaces afterColon + -- Check if value is on same line or next line + case afterColonSpaces of + ('\n':rest) -> do + -- Multi-line value (object or array) + case peekIndent rest of + Just nextIndent | nextIndent >= indent -> do + -- Check if it's an array or object + if isArrayAtIndent nextIndent rest + then do + (val, rest2) <- runParser (parseArray nextIndent) rest + Right ((key, val), rest2) + else if nextIndent > indent + then do + (val, rest2) <- runParser (parseObject nextIndent) rest + Right ((key, val), rest2) + else Right ((key, YRecord []), rest) + _ -> Right ((key, YRecord []), rest) + _ -> do + -- Inline value + (val, rest) <- runParser parseInlineValue afterColonSpaces + Right ((key, val), rest) + +-- | Parse YAML object - collect all KVs at this indent level +parseObject :: Int -> Parser YAMLValue +parseObject indent = Parser $ \input -> + let loop acc inp = case peekIndent inp of + Just i | i == indent -> + -- Check if it's a key-value pair (not an array item) + case runParser skipEmpty inp of + Right ((), afterEmpty) -> + let afterSpaces = drop i afterEmpty + in if "-" `isPrefixOf` afterSpaces + then Right (reverse acc, inp) -- Stop if we hit an array item + else case runParser (parseKV indent) inp of + Right ((k, v), rest) -> loop ((k, v):acc) rest + Left err -> Left err + Left err -> Left err + _ -> Right (reverse acc, inp) + in case loop [] input of + Right (pairs, rest) -> Right (YRecord pairs, rest) + Left err -> Left err + +-- | Parse array item +parseArrayItem :: Int -> Parser YAMLValue +parseArrayItem indent = Parser $ \input -> do + -- Skip empty and get to the dash + ((), afterEmpty) <- runParser skipEmpty input + ((), afterIndent) <- runParser (exactSpaces indent) afterEmpty + (_, afterDash) <- runParser (char '-') afterIndent + ((), afterSpaces) <- runParser skipSpaces afterDash + + case afterSpaces of + ('\n':rest) -> do + -- Multi-line item (object or array on next line) + case peekIndent rest of + Just nextIndent | nextIndent > indent -> + runParser (parseValue nextIndent) rest + _ -> Right (YRecord [], rest) + _ -> do + -- Content on same line as dash + -- Try to parse as "key: value" to start an object + case runParser parseKey afterSpaces of + Right (key, afterKey) -> do + ((), afterKeySpaces) <- runParser skipSpaces afterKey + case runParser (char ':') afterKeySpaces of + Right (_, afterColon) -> do + -- This is "- key: ..." format, parse as object + -- Parse this first key-value pair + ((), afterColonSpaces) <- runParser skipSpaces afterColon + case afterColonSpaces of + ('\n':rest) -> do + -- Value on next lines + case peekIndent rest of + Just nextIndent | nextIndent > indent -> do + -- Parse the value for this key + (val, rest2) <- runParser (parseValue nextIndent) rest + -- Check for more sibling keys at indent+2 + let continueParsingKeys acc r = case peekIndent r of + Just i | i == indent + 2 && not (isArrayAtIndent i r) -> + case runParser (parseKV (indent + 2)) r of + Right ((k, v), r2) -> continueParsingKeys ((k,v):acc) r2 + Left _ -> Right (reverse acc, r) + _ -> Right (reverse acc, r) + (morePairs, rest3) <- continueParsingKeys [(key, val)] rest2 + Right (YRecord morePairs, rest3) + _ -> Right (YRecord [(key, YRecord [])], rest) + _ -> do + -- Inline value + (val, rest) <- runParser parseInlineValue afterColonSpaces + -- Check for more keys at indent+2 + let continueParsingKeys acc r = case peekIndent r of + Just i | i == indent + 2 && not (isArrayAtIndent i r) -> + case runParser (parseKV (indent + 2)) r of + Right ((k, v), r2) -> continueParsingKeys ((k,v):acc) r2 + Left _ -> Right (reverse acc, r) + _ -> Right (reverse acc, r) + (morePairs, rest2) <- continueParsingKeys [(key, val)] rest + Right (YRecord morePairs, rest2) + Left _ -> do + -- Not "key:", treat whole line as string + runParser parseInlineValue afterSpaces + Left _ -> do + -- Can't parse as key, treat as inline string value + runParser parseInlineValue afterSpaces + +-- | Parse YAML array - collect all items at this indent level +parseArray :: Int -> Parser YAMLValue +parseArray indent = Parser $ \input -> + let loop acc inp = case peekIndent inp of + Just i | i == indent && isArrayAtIndent i inp -> + case runParser (parseArrayItem indent) inp of + Right (item, rest) -> loop (item:acc) rest + Left err -> Left err + _ -> Right (reverse acc, inp) + in case loop [] input of + Right (items, rest) -> Right (YArray items, rest) + Left err -> Left err + +-- | Check if there's an array item at the given indent +isArrayAtIndent :: Int -> String -> Bool +isArrayAtIndent indent input = + let cleaned = dropWhile (\c -> c == '\n' || c == '#') (dropComment input) + spaces = countSpaces cleaned + rest = drop spaces cleaned + in spaces == indent && "-" `isPrefixOf` rest + where + dropComment s = case s of + ('#':rest) -> dropWhile (/= '\n') rest + _ -> s + +-- | Parse any YAML value +parseValue :: Int -> Parser YAMLValue +parseValue indent = Parser $ \input -> + case runParser skipEmpty input of + Right ((), rest) -> + if isArrayAtIndent indent rest + then runParser (parseArray indent) rest + else runParser (parseObject indent) rest + Left err -> Left err + +-- | Parse entire YAML document +parseYaml :: String -> Either String YAMLValue +parseYaml input = do + (val, _) <- runParser (parseObject 0) input + return val diff --git a/src/Text/ParserComb.hs b/src/Text/ParserComb.hs --- a/src/Text/ParserComb.hs +++ b/src/Text/ParserComb.hs @@ -19,8 +19,6 @@ TokenMachine(..), mapTokenState, ) where ---Ximport Prelude() -import Prelude import Control.Applicative import Control.Monad @@ -205,4 +203,3 @@ esepEndBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure []) -