MicroCabal 0.3.1.2 → 0.5.10.0
raw patch · 12 files changed
+855/−340 lines, 12 filesdep ~base
Dependency ranges changed: base
Files
- MicroCabal.cabal +4/−3
- src/MicroCabal/Backend/GHC.hs +34/−16
- src/MicroCabal/Backend/MHS.hs +119/−55
- src/MicroCabal/Cabal.hs +28/−1
- src/MicroCabal/Env.hs +27/−11
- src/MicroCabal/Main.hs +229/−120
- src/MicroCabal/Normalize.hs +11/−4
- src/MicroCabal/Parse.hs +67/−108
- src/MicroCabal/StackageList.hs +6/−14
- src/MicroCabal/Unix.hs +22/−5
- src/MicroCabal/YAML.hs +308/−0
- src/Text/ParserComb.hs +0/−3
MicroCabal.cabal view
@@ -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,
src/MicroCabal/Backend/GHC.hs view
@@ -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.
src/MicroCabal/Backend/MHS.hs view
@@ -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]
src/MicroCabal/Cabal.hs view
@@ -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
src/MicroCabal/Env.hs view
@@ -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
src/MicroCabal/Main.hs view
@@ -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
src/MicroCabal/Normalize.hs view
@@ -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'
src/MicroCabal/Parse.hs view
@@ -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)
src/MicroCabal/StackageList.hs view
@@ -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
src/MicroCabal/Unix.hs view
@@ -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 -----
src/MicroCabal/YAML.hs view
@@ -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
src/Text/ParserComb.hs view
@@ -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 [])-