MicroCabal (empty) → 0.1.0.0
raw patch · 15 files changed
+1883/−0 lines, 15 filesdep +basedep +directorydep +process
Dependencies added: base, directory, process
Files
- LICENSE +202/−0
- Makefile +23/−0
- MicroCabal.cabal +42/−0
- README.md +9/−0
- src/MicroCabal/Backend/GHC.hs +149/−0
- src/MicroCabal/Backend/MHS.hs +94/−0
- src/MicroCabal/Cabal.hs +127/−0
- src/MicroCabal/Env.hs +23/−0
- src/MicroCabal/Main.hs +288/−0
- src/MicroCabal/Normalize.hs +78/−0
- src/MicroCabal/Parse.hs +479/−0
- src/MicroCabal/StackageList.hs +70/−0
- src/MicroCabal/Unix.hs +76/−0
- src/MicroCabal/YAML.hs +17/−0
- src/Text/ParserComb.hs +206/−0
+ LICENSE view
@@ -0,0 +1,202 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/+ Copyright Lennart Augustsson 2024++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Makefile view
@@ -0,0 +1,23 @@+MHSDIR=../MicroHs+MHS=$(MHSDIR)/bin/mhs++bin/mcabal: src/MicroCabal/*.hs src/MicroCabal/*/*.hs+ @mkdir -p bin+ MHSDIR=$(MHSDIR) $(MHS) -C -isrc -obin/mcabal MicroCabal.Main++bin/gmcabal: src/MicroCabal/*.hs src/MicroCabal/*/*.hs+ @mkdir -p bin+ ghc -outputdir ghc-out -Wall -Wno-unrecognised-warning-flags -Wno-x-partial --make -isrc -o bin/gmcabal -main-is MicroCabal.Main -package directory -package process MicroCabal.Main++all: bin/gmcabal bin/mcabal++clean:+ rm -rf ghc-out bin/*+ cabal clean++test: bin/mcabal+ bin/mcabal parse MicroCabal.cabal+ bin/mcabal parse ../MicroHs/MicroHs.cabal+ bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/polyparse-1.12/polyparse.cabal+ bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/cpphs-1.20.9/cpphs.cabal+ bin/mcabal parse ../Hackage/optparse-applicative-0.18.1.0/optparse-applicative.cabal
+ MicroCabal.cabal view
@@ -0,0 +1,42 @@+cabal-version: 3.0+name: MicroCabal+version: 0.1.0.0+synopsis: A Cabal replacement+license: Apache-2.0+license-file: LICENSE+copyright: 2024 Lennart Augustsson+category: language+author: lennart@augustsson.net+maintainer: lennart@augustsson.net+stability: experimental+description: A portable subset of the Cabal functionality.+build-type: Simple++extra-source-files:+ LICENSE+ Makefile+ README.md++source-repository head+ type: git+ location: https://github.com/augustss/MicroCabal++executable mcabal+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -main-is MicroCabal.Main+ main-is: MicroCabal/Main.hs+ default-extensions: ScopedTypeVariables MultiParamTypeClasses+ other-modules: MicroCabal.Backend.GHC+ MicroCabal.Backend.MHS+ MicroCabal.Cabal+ MicroCabal.Env+ MicroCabal.Normalize+ MicroCabal.Parse+ MicroCabal.StackageList+ MicroCabal.Unix+ MicroCabal.YAML+ Text.ParserComb+ build-depends: base >= 4.10 && < 4.20,+ directory >= 1.3 && < 1.5,+ process >= 1.6 && < 1.8,
+ README.md view
@@ -0,0 +1,9 @@+# MicroCabal+This repository contains a reimplementation of a subset of Cabal.++Why a reimplementation? Because Cabal is not a Haskell tool, it is a ghc tool.+A Haskell tool should be compilable by an implementation of Haskell2010,+which Cabal is definitely not.++The implementation assumes a Unix-like system with commands like `wget` and `tar`.+
+ src/MicroCabal/Backend/GHC.hs view
@@ -0,0 +1,149 @@+module MicroCabal.Backend.GHC(ghcBackend) where+import Control.Monad+import Data.Version+import System.Directory+import MicroCabal.Cabal+import MicroCabal.Env+import MicroCabal.Unix++ghcBackend :: Backend+ghcBackend = Backend {+ backendName = "ghc",+ doesPkgExist = ghcExists,+ buildPkgExe = ghcBuildExe,+ buildPkgLib = ghcBuildLib,+ installPkgExe = ghcInstallExe,+ installPkgLib = ghcInstallLib+ }++getGhcName :: Env -> IO FilePath+getGhcName env = ("ghc-" ++) . takeWhile (/= '\n') <$> cmdOut env "ghc --numeric-version"++getGhcDir :: Env -> IO FilePath+getGhcDir env = ((cabalDir env ++ "/") ++) <$> getGhcName env++getBuildDir :: Env -> IO FilePath+getBuildDir env = do+ ghc <- getGhcName env+ return $ distDir env ++ "/build/" ++ ghc++initDB :: Env -> IO ()+initDB env = do+ dir <- getGhcDir env+ b <- doesDirectoryExist dir+ when (not b) $ do+ when (verbose env > 0) $+ putStrLn $ "Creating GHC package db " ++ dir+ cmd env $ "ghc-pkg init " ++ dir++ghcExists :: Env -> PackageName -> IO Bool+ghcExists env pkgname = do+ dir <- getGhcDir env+ tryCmd env $ "ghc-pkg --package-db=" ++ dir ++ " describe >/dev/null 2>/dev/null " ++ pkgname++setupStdArgs :: Env -> [Field] -> IO [String]+setupStdArgs env flds = do+ db <- getGhcDir env+ let srcDirs = getFieldStrings flds ["."] "hs-source-dirs"+ defExts = getFieldStrings flds [] "default-extensions"+ exts = getFieldStrings flds defExts "extensions"+ opts = getFieldStrings flds [] "ghc-options"+ cppOpts = getFieldStrings flds [] "cpp-options"+ deps = getBuildDependsPkg flds+ buildDir <- getBuildDir env+ return $ [ "-package-env=-", "-package-db=" ++ db, "-outputdir=" ++ buildDir, "-w"] +++ map ("-i" ++) srcDirs +++ map ("-X" ++) exts +++ map ("-package " ++) deps +++ opts ++ cppOpts++binGhc :: String+binGhc = "/bin/ghc/"++ghcBuildExe :: Env -> Section -> Section -> IO ()+ghcBuildExe env _ (Section _ name flds) = do+ initDB env+ let mainIs = getFieldString flds "main-is"+ srcDirs = getFieldStrings flds ["."] "hs-source-dirs"+ bin = distDir env ++ binGhc ++ name+ mkdir env $ distDir env ++ binGhc+ mainIs' <- findMainIs env srcDirs mainIs+ stdArgs <- setupStdArgs env flds+ let args = unwords $ ["-O"] ++ stdArgs ++ ["-o", bin, "--make", mainIs']+ when (verbose env >= 0) $+ putStrLn $ "Build executable " ++ bin ++ " with ghc"+ cmd env $ "ghc " ++ args++findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath+findMainIs _ [] fn = error $ "cannot find " ++ show fn+findMainIs env (d:ds) fn = do+ let fn' = d ++ "/" ++ fn+ b <- doesFileExist fn'+ if b then+ return fn'+ else+ findMainIs env ds fn++getExposedModules :: [Field] -> [String]+getExposedModules flds = getFieldStrings flds (error "no exposed-modules") "exposed-modules"++ghcBuildLib :: Env -> Section -> Section -> IO ()+ghcBuildLib env (Section _ _ glob) (Section _ name flds) = do+ initDB env+ stdArgs <- setupStdArgs env flds+ let mdls = getExposedModules flds+ ver = getVersion glob "version"+ args = unwords $ ["-O"] ++ stdArgs +++ ["--make", "-no-link", "-this-unit-id", key ] +++ ["-fbuilding-cabal-package", "-static" ] +++ mdls+ key = name ++ "-" ++ showVersion ver ++ "-mcabal"+ when (verbose env >= 0) $+ putStrLn $ "Build library " ++ name ++ " with ghc"+ cmd env $ "ghc " ++ args++ghcInstallExe :: Env -> Section -> Section -> IO ()+ghcInstallExe env (Section _ _ _glob) (Section _ name _) = do+ let bin = distDir env ++ binGhc ++ name+ binDir = cabalDir env ++ "/bin"+ mkdir env binDir+ cp env bin (binDir ++ "/" ++ name)++ghcInstallLib :: Env -> Section -> Section -> IO ()+ghcInstallLib env (Section _ _ glob) (Section _ name flds) = do+ initDB env+ buildDir <- getBuildDir env+ ghc <- getGhcDir env+ let namever = name ++ "-" ++ showVersion vers+ destDir = ghc ++ "/" ++ namever+ vers = getVersion glob "version"+ arch = destDir ++ "/" ++ "libHS" ++ namever ++ "-mcabal.a"+ mkdir env destDir+ rmrf env arch+ cmd env $ "ar -c -r -s " ++ arch ++ " `find " ++ buildDir ++ " -name '*.o'`"++ let files = map mdlToHi mdls+ mdls = getExposedModules flds+ mdlToHi = (++ ".hi") . map (\ c -> if c == '.' then '/' else c)+ copyFiles env buildDir files destDir++ db <- getGhcDir env+ let desc = unlines+ [ "name: " ++ name+ , "version: " ++ showVersion vers+ , "visibility: public"+ , "id: " ++ key+ , "key: " ++ key+ , "exposed: True"+ , "exposed-modules: " ++ unwords mdls+ , "import-dirs: " ++ destDir+ , "library-dirs: " ++ destDir+ , "library-dirs-static: " ++ destDir+ , "hs-libraries: HS" ++ key+ , "depends: " ++ unwords depends+ ]+ depends = [] -- XXX+ key = namever ++ "-mcabal"+ pkgFn = db ++ "/" ++ key ++ ".conf"+ writeFile pkgFn desc+ cmd env $ "ghc-pkg update --package-db=" ++ db ++ " " ++ pkgFn
+ src/MicroCabal/Backend/MHS.hs view
@@ -0,0 +1,94 @@+module MicroCabal.Backend.MHS(mhsBackend) where+import Control.Monad+import System.Directory+import MicroCabal.Cabal+import MicroCabal.Env+import MicroCabal.Unix++mhsBackend :: Backend+mhsBackend = Backend {+ backendName = "mhs",+ doesPkgExist = mhsExists,+ buildPkgExe = mhsBuildExe,+ buildPkgLib = mhsBuildLib,+ installPkgExe = mhsInstallExe,+ installPkgLib = mhsInstallLib+ }++-- XXX needs version info+getMhsDir :: Env -> IO FilePath+getMhsDir env = return $ cabalDir env ++ "/mhs"++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++mhsExists :: Env -> PackageName -> IO Bool+mhsExists env _pkgname = do+ _dir <- getMhsDir env+ return False++setupStdArgs :: Env -> [Field] -> [String]+setupStdArgs _env flds =+ let srcDirs = getFieldStrings flds ["."] "hs-source-dirs"+ defExts = getFieldStrings flds [] "default-extensions"+ exts = getFieldStrings flds defExts "extensions"+ opts = getFieldStrings flds [] "mhs-options"+ cppOpts = getFieldStrings flds [] "cpp-options"+ exts' = filter (`elem` mhsX) exts+ mhsX = ["CPP"]+ in map ("-i" ++) srcDirs +++ map ("-X" ++) exts' +++ opts ++ cppOpts++binMhs :: String+binMhs = "/bin/ghc/"++mhsBuildExe :: Env -> Section -> Section -> IO ()+mhsBuildExe env _ (Section _ name flds) = do+ initDB env+ let mainIs = getFieldString flds "main-is"+ srcDirs = getFieldStrings flds ["."] "hs-source-dirs"+ bin = distDir env ++ binMhs ++ name+ mkdir env $ distDir env ++ binMhs+ mainIs' <- findMainIs env srcDirs mainIs+ let args = unwords $ setupStdArgs env flds +++ ["-o" ++ bin, mainIs']+ when (verbose env >= 0) $+ putStrLn $ "Build " ++ bin ++ " with mhs"+ --putStrLn $ "mhs " ++ args+ cmd env $ "MHSDIR=/usr/local/lib/mhs " ++ -- temporary hack+ "mhs " ++ args++findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath+findMainIs _ [] fn = error $ "cannot find " ++ show fn+findMainIs env (d:ds) fn = do+ let fn' = d ++ "/" ++ fn+ b <- doesFileExist fn'+ if b then+ return fn'+ else+ findMainIs env ds fn++mhsBuildLib :: Env -> Section -> Section -> IO ()+mhsBuildLib env _ (Section _ name flds) = do+ initDB env+ let mdls = getFieldStrings flds (error "no exposed-modules") "exposed-modules"+ args = unwords $ ["-P" ++ name] +++ setupStdArgs env flds ++ mdls+ error $ "No mhsBuildLib\n" ++ show args++mhsInstallExe :: Env -> Section -> Section -> IO ()+mhsInstallExe env (Section _ _ _glob) (Section _ name _) = do+ let bin = distDir env ++ binMhs ++ name+ binDir = cabalDir env ++ "/bin"+ cp env bin binDir++mhsInstallLib :: Env -> Section -> Section -> IO ()+mhsInstallLib env _glob _sect = do+ initDB env+ undefined
+ src/MicroCabal/Cabal.hs view
@@ -0,0 +1,127 @@+module MicroCabal.Cabal(+ Version(..), makeVersion,+ FieldName, Name,+ Cabal(..),+ Value(..),+ Field(..),+ Cond(..),+ Section(..),+ SectionType,+ VersionRange(..),+ Item,+ FlagInfo(..),+ showCabal, showSection,+ getFieldString,+ getFieldStrings,+ getBuildDepends,+ getBuildDependsPkg,+ getVersion,+ ) where+import Data.Version++--type ExecName = String+type FieldName = String+type Name = String++newtype Cabal = Cabal [Section]+ deriving (Show)++data Value+ = VItems [Item]+ | VItem Item+ | VBool Bool+ | VVersion Version+ | VRange VersionRange+ | VPkgs [(Item, [Item], Maybe VersionRange)]+ deriving (Show)++data Field+ = Field FieldName Value+ | If Cond [Field] [Field]+ deriving (Show)++data Cond+ = CBool Bool+ | Cos Item+ | Carch Item+ | Cimpl Item (Maybe VersionRange)+ | Cflag Item+ | Cnot Cond+ | Cand Cond Cond+ | Cor Cond Cond+ deriving (Show)++data Section = Section SectionType Name [Field]+ deriving (Show)++type SectionType = String++data VersionRange+ = VEQ Version+ | VGT Version+ | VLT Version+ | VLE Version+ | VGE Version+ | VGEHat Version+ | VEQWild Version+ | VOr VersionRange VersionRange+ | VAnd VersionRange VersionRange+ | VEQSet [Version]+ | VGEHatSet [Version]+ deriving (Show)++type Item = String++data FlagInfo = FlagInfo+ { os :: String+ , arch :: String+ , impl :: (String, Version)+ , flags :: [(Name, Bool)]+ }+ deriving (Show)++showCabal :: Cabal -> String+showCabal (Cabal sects) =+ "Cabal\n" ++ unlines (map showSection sects)++showField :: Field -> String+showField (Field n v) = " Field " ++ n ++ ": " ++ show v+showField (If c t e) =+ " If " ++ show c ++ "\n" +++ unlines (map (indent . showField) t) +++ if null e then "" else+ " Else\n" +++ unlines (map (indent . showField) e)++indent :: String -> String+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 ++getFieldString :: [Field] -> FieldName -> String+getFieldString flds n =+ case [ s | Field f (VItem s) <- flds, f == n ] of+ [s] -> s+ _ -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)++getFieldStrings :: [Field] -> [String] -> FieldName -> [String]+getFieldStrings flds def n =+ case [ ss | Field f (VItems ss) <- flds, f == n ] of+ [ss] -> ss+ _ -> def++getBuildDepends :: [Field] -> [(Item, [Item], Maybe VersionRange)]+getBuildDepends fs =+ case [ d | Field "build-depends" (VPkgs d) <- fs ] of+ [d] -> d+ _ -> []++getBuildDependsPkg :: [Field] -> [String]+getBuildDependsPkg = map (\ (p,_,_) -> p) . getBuildDepends++getVersion :: [Field] -> String -> Version+getVersion flds n =+ case [ s | Field f (VVersion s) <- flds, f == n ] of+ [s] -> s+ _ -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)
+ src/MicroCabal/Env.hs view
@@ -0,0 +1,23 @@+module MicroCabal.Env(+ Env(..),+ Backend(..),+ PackageName,+ ) where+import MicroCabal.Cabal+import MicroCabal.StackageList(PackageName)++data Env = Env {+ cabalDir :: FilePath,+ distDir :: FilePath,+ verbose :: Int,+ backend :: Backend+ }++data Backend = Backend {+ backendName :: String, -- name of backaned+ doesPkgExist :: Env -> PackageName -> IO Bool, -- is the package available in the database?+ buildPkgExe :: Env -> Section -> Section -> IO (), -- build executable the current directory+ buildPkgLib :: Env -> Section -> Section -> IO (), -- build the package in the current directory+ installPkgExe :: Env -> Section -> Section -> IO (), -- install the package from the current directory+ installPkgLib :: Env -> Section -> Section -> IO () -- install the package from the current directory+ }
+ src/MicroCabal/Main.hs view
@@ -0,0 +1,288 @@+module MicroCabal.Main where+import Control.Monad+import Data.List+import Data.Maybe+import Data.Version+import System.Environment+import System.Directory+import qualified System.Info as I+import Text.Read+import MicroCabal.Backend.GHC+import MicroCabal.Backend.MHS+import MicroCabal.Cabal+import MicroCabal.Env+import MicroCabal.Normalize+import MicroCabal.Parse+import MicroCabal.StackageList+import MicroCabal.Unix+import MicroCabal.YAML++main :: IO ()+main = do+ (env, args) <- decodeCommonArgs =<< setupEnv++ case args of+ [] -> usage+ "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+ _ -> usage++setupEnv :: IO Env+setupEnv = do+ home <- getEnv "HOME"+ let cdir = home ++ "/.mcabal"+ return Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, backend = mhsBackend }++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 ("--ghc" : as) = loop e{ backend = ghcBackend } as+ loop e ("--mhs" : as) = loop e{ backend = mhsBackend } as+ loop e as = return (e, as)+ loop env =<< getArgs++usage :: IO ()+usage = do+ putStrLn "\+\Usage:\n\+\ mcabal [FLAGS] build [PKG]\n\+\ mcabal [FLAGS] clean\n\+\ mcabal [FLAGS] fetch PKG\n\+\ mcabal [FLAGS] help\n\+\ mcabal [FLAGS] install\n\+\ mcabal [FLAGS] update\n\+\"+ error "done"++-----------------------------------------++-- Package list+packageListName :: FilePath+packageListName = "packages.txt"++-- Local name for snapshot list+snapshotsName :: FilePath+snapshotsName = "snapshots.json"++-- Local name for snapshot+snapshotName :: FilePath+snapshotName = "snapshot.yaml"++-- This is a JSON document describing enumerating all releases.+stackageSourceList :: URL+stackageSourceList = URL "https://www.stackage.org/download/snapshots.json"++snapshotSource :: String+snapshotSource = "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" -- lts/22/13.yaml++-- XX This needs improvement+getBestStackage :: Env -> IO URL+getBestStackage env = do+ -- Get source list+ let dir = cabalDir env+ fsnaps = dir ++ "/" ++ snapshotsName+ wget env stackageSourceList fsnaps+ file <- readFile fsnaps+ let snaps = parseSnapshots fsnaps file+ snap = snd $ last $+ [(0::Int, error "no lts snapshots found")] +++ sort [ (l, r) | (lp, r) <- snaps, Just l <- [stripPrefix "lts-" lp >>= readMaybe] ]+ snap' = map (\ c -> if c == '-' || c == '.' then '/' else c) snap+ when (verbose env > 0) $+ putStrLn $ "Picking Stackage snapshot " ++ snap+ return $ URL $ snapshotSource ++ snap' ++ ".yaml"++cmdUpdate :: Env -> [String] -> IO ()+cmdUpdate env _args = do+ when (verbose env >= 0) $+ putStrLn "Retrieving Stackage package list"+ let dir = cabalDir env+ stk = dir ++ "/" ++ snapshotName+ fpkgs = dir ++ "/" ++ packageListName+ mkdir env dir+ url <- getBestStackage env+ wget env url stk+ file <- readFile stk+ let yml = parseYAML stk file+ pkgs = yamlToStackageList yml+-- putStrLn $ showYAML yml+-- putStrLn $ show pkgs+ when (verbose env > 0) $+ putStrLn $ "Write package list to " ++ fpkgs+ writeFile fpkgs $ unlines $ map showPackage pkgs++cmdTest :: Env -> [String] -> IO ()+cmdTest _ _ = do+ let stk = "11.yaml"+ file <- readFile stk+ let yml = parseYAML stk file+ putStrLn $ showYAML yml+++-----------------------------------------++hackageSrcURL :: String+hackageSrcURL = "https://hackage.haskell.org/package/"++getPackageList :: Env -> IO [StackagePackage]+getPackageList env = do+ let dir = cabalDir env+ fpkgs = dir ++ "/" ++ packageListName+ b <- doesFileExist fpkgs+ when (not b) $ do+ when (verbose env >= 0) $+ putStrLn "No package list, running 'update' command"+ cmdUpdate env []+ map readPackage . lines <$> readFile fpkgs++getPackageInfo :: Env -> PackageName -> IO StackagePackage+getPackageInfo env pkg = do+ pkgs <- getPackageList env+ return $ fromMaybe (error $ "getPackageInfo: no package " ++ pkg) $ listToMaybe $ filter ((== pkg) . stName) pkgs++dirPackage :: Env -> FilePath+dirPackage env = cabalDir env ++ "/packages"++dirForPackage :: Env -> StackagePackage -> FilePath+dirForPackage env st = dirPackage env ++ "/" ++ stName st ++ "-" ++ showVersion (stVersion st)++cmdFetch :: Env -> [String] -> IO ()+cmdFetch env [pkg] = do+ st <- getPackageInfo env pkg+ let pkgs = stName st ++ "-" ++ showVersion (stVersion st)+ url = URL $ hackageSrcURL ++ pkgs ++ "/" ++ pkgz+ pkgz = pkgs ++ ".tar.gz"+ pdir = dirForPackage env st+ file = pdir ++ ".tar.gz"+ b <- doesDirectoryExist pdir+ when (not b) $ do+ mkdir env pdir+ when (verbose env > 0) $+ putStrLn $ "Fetching " ++ pkgz+ wget env url file+ when (verbose env > 0) $+ putStrLn $ "Unpacking " ++ pkgz+ tarx env (dirPackage env) file+cmdFetch _ _ = usage++-----------------------------------------++findCabalFile :: Env -> IO FilePath+findCabalFile _env = do+ ns <- listDirectory "."+ case filter (".cabal" `isSuffixOf`) ns of+ [] -> error "no PKG.cabal file"+ [n] -> return n+ _ -> error "multiple PKG.cabal file"++cmdBuild :: Env -> [String] -> IO ()+cmdBuild env [] = build env+cmdBuild env [pkg] = do+ st <- getPackageInfo env pkg+ let dir = dirForPackage env st+ b <- doesDirectoryExist dir+ when (not b) $ do+ when (verbose env >= 0) $+ putStrLn $ "Package not found, running 'fetch " ++ pkg ++ "'"+ cmdFetch env [pkg]+ when (verbose env >= 0) $+ putStrLn $ "Building in " ++ dir+ setCurrentDirectory dir+ cmdBuild env []+cmdBuild _ _ = usage++getGlobal :: Cabal -> Section+getGlobal (Cabal sects) =+ fromMaybe (error "no global section") $ listToMaybe [ s | s@(Section "global" _ _) <- sects ]++build :: Env -> IO ()+build env = do+ fn <- findCabalFile env+ rfile <- readFile fn+ let cbl = parseCabal fn rfile+ info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+ ncbl@(Cabal sects) = normalize info cbl+ glob = getGlobal ncbl+ sect s@(Section "executable" _ _) = buildExe env glob s+ sect s@(Section "library" _ _) = buildLib env glob s+ sect _ = return ()+ mapM_ sect sects++buildExe :: Env -> Section -> Section -> IO ()+buildExe env glob sect@(Section _ _ flds) = do+ let deps = getBuildDepends flds+ pkgs = [ p | (p, _, _) <- deps ]+ mapM_ (checkDep env) pkgs+ buildPkgExe (backend env) env glob sect++buildLib :: Env -> Section -> Section -> IO ()+buildLib env glob sect@(Section _ _ flds) = do+ let pkgs = getBuildDependsPkg flds+ mapM_ (checkDep env) pkgs+ buildPkgLib (backend env) env glob sect++checkDep :: Env -> PackageName -> IO ()+checkDep _env pkg | pkg `elem` builtinPackages = return ()+checkDep env pkg = do+ let bend = backend env+ b <- doesPkgExist bend env pkg+ when (not b) $+ error $ "dependency not installed: " ++ pkg++builtinPackages :: [String]+builtinPackages = ["base", "directory", "process", "bytestring", "text", "fail", "time"]++-----------------------------------------++cmdInstall :: Env -> [String] -> IO ()+cmdInstall env args = do+ -- The will build and change current directory+ cmdBuild env args+ install env++install :: Env -> IO ()+install env = do+ fn <- findCabalFile env+ rfile <- readFile fn+ let cbl = parseCabal fn rfile+ info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+ ncbl@(Cabal sects) = normalize info cbl+ glob = getGlobal ncbl+ sect s@(Section "executable" _ _) = installExe env glob s+ sect s@(Section "library" _ _) = installLib env glob s+ sect _ = return ()+ mapM_ sect sects++installExe :: Env -> Section -> Section -> IO ()+installExe env = installPkgExe (backend env) env++installLib :: Env -> Section -> Section -> IO ()+installLib env = installPkgLib (backend env) env++-----------------------------------------++cmdHelp :: Env -> [String] -> IO ()+cmdHelp _ _ = putStrLn "Coming soon"++-----------------------------------------++cmdClean :: Env -> [String] -> IO ()+cmdClean env _ = rmrf env (distDir env)++-----------------------------------------++cmdParse :: Env -> [String] -> IO ()+cmdParse _env [fn] = do+ rfile <- readFile fn+ let cbl = parseCabal fn rfile+ info = FlagInfo { os = I.os, arch = I.arch, flags = [], impl = (I.compilerName, I.compilerVersion) }+ ncbl = normalize info cbl+ --putStrLn $ showCabal cbl+ putStrLn $ showCabal ncbl+cmdParse _ _ = undefined
+ src/MicroCabal/Normalize.hs view
@@ -0,0 +1,78 @@+module MicroCabal.Normalize(normalize) where+import Data.Function+import Data.List+import Data.Maybe+import MicroCabal.Cabal++-- Do some normalization+-- * computre conditionals and flatten 'if/else'+-- * inline 'import'+-- * combine identical fields+-- * set library name++normalize :: FlagInfo -> Cabal -> Cabal+normalize info = libName . combine . inline . reduce info++combine :: Cabal -> Cabal+combine (Cabal ss) = Cabal $ map (\ (Section s n fs) -> Section s n (combineFields fs)) ss++combineFields :: [Field] -> [Field]+combineFields = map (foldl1 comb) . groupBy ((==) `on` fieldName) . sortBy (compare `on` fieldName)+ where fieldName (Field n _) = n+ fieldName _ = undefined -- Cannot happen, the Ifs are gone+ comb (Field n v1) (Field _ v2) = Field n (combineValue n v1 v2)+ comb _ _ = undefined++combineValue :: FieldName -> Value -> Value -> Value+combineValue _ (VItem x) (VItem y) | x == y = VItem x+combineValue _ (VItems xs) (VItems ys) = VItems (xs ++ ys)+combineValue _ (VBool x) (VBool y) = VBool (x && y)+combineValue _ (VPkgs xs) (VPkgs ys) = VPkgs (xs ++ ys)+combineValue n v1 v2 = error $ "fields " ++ show n ++ " cannot be combined, values=" ++ show (v1, v2)++inline :: Cabal -> Cabal+inline (Cabal ss) = Cabal (map sect nss)+ where (css, nss) = partition (\ (Section s _ _) -> s == "common") ss+ coms = [ (n, fs) | Section _ n fs <- css ]+ sect (Section s n fs) = Section s n $ concatMap inl fs+ inl (Field "import" (VItem n)) = fromMaybe (error $ "No common " ++ show n) $ lookup n coms+ inl f = [f]++libName :: Cabal -> Cabal+libName (Cabal []) = undefined+libName (Cabal (g@(Section _ _ gs):ss)) = Cabal $ g : map set ss+ where set (Section "library" "" fs) = Section "library" name fs+ set s = s+ name = head $ [ n | Field "name" (VItem n) <- gs ] ++ [error "no name field"] ++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 _ = []+ dflt n fs = head $ [ b | Field "default" (VBool b) <- fs ] ++ [error $ "no default for flag " ++ show n]++reduce' :: FlagInfo -> Cabal -> Cabal+reduce' info = mapField red+ where red (If c t e) | cond info c = concatMap red t+ | otherwise = concatMap red e+ red f = [f]++mapField :: (Field -> [Field]) -> Cabal -> Cabal+mapField f (Cabal ss) = Cabal (map sect ss)+ where+ sect (Section s n fs) = Section s n (concatMap f fs)++cond :: FlagInfo -> Cond -> Bool+cond info = eval+ where eval (CBool b) = b+ eval (Cand a b) = eval a && eval b+ eval (Cor a b) = eval a || eval b+ 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++inVersionRange :: Version -> VersionRange -> Bool+inVersionRange _ _ = True -- XXX
+ src/MicroCabal/Parse.hs view
@@ -0,0 +1,479 @@+module MicroCabal.Parse(+ parseCabal,+ parseYAML,+ parseSnapshots,+ ) where+import Control.Applicative+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Text.ParserComb+import MicroCabal.Cabal+import MicroCabal.YAML+--import Debug.Trace++parseCabal :: FilePath -> String -> Cabal+parseCabal fn rfile = runP pCabalTop fn $ dropCabalComments rfile++parseYAML :: FilePath -> String -> YAMLValue+parseYAML fn rfile = runP pYAMLTop fn $ dropYAMLComments rfile++parseSnapshots :: FilePath -> String -> [(String, String)]+parseSnapshots fn rfile = runP pSnapshotsTop fn rfile++runP :: P a -> FilePath -> String -> a+runP prsr fn file =+ case runPrsr prsr (initLexState file) of+ Left (LastFail n ts msgs) -> error $ "\n" +++ " found: " ++ (map show ts ++ ["EOF"]) !! 0 ++ "\n" +++ " expected: " ++ unwords (nub msgs) ++ "\n" +++-- " n=" ++ show n ++ "\n" +++ " file: " ++ show fn ++ "\n" +++ " line: " ++ show (1 + length (filter (== '\n') (take (length file - n) file))) ++ "\n" +++ " at: " ++ show (take 100 (drop (length file - n) file))+ Right (a:_) -> a+ Right [] -> undefined -- impossible+++------------------------------++type P a = Prsr LexState Char a++data LexState = LS Int [Int] [Char]+ deriving (Show)++initLexState :: [Char] -> LexState+initLexState cs = LS 0 [] cs++end :: Char+end = '\EOT'+fieldSep :: Char+fieldSep = '\FS'++instance TokenMachine LexState Char where+-- tmNextToken ls | trace ("tmNextToken: " ++ show ls) False = undefined+ tmNextToken ls@(LS _ [] []) = (end, ls) -- ugly hack+ tmNextToken (LS i (_:ks) []) = (fieldSep, LS i ks [])+ tmNextToken (LS i [] (c:cs)) | c == '\n' = (c, LS 0 [] cs)+ | otherwise = (c, LS (i+1) [] cs)+ tmNextToken (LS i kks@(k:ks) (c:cs)) | c /= '\n' = (c, LS (i+1) kks cs)+ | Just cs' <- skipEmpty cs = tmNextToken (LS i kks cs')+ | otherwise =+ let lead 0 _ =+-- trace ("Just NL kks=" ++ show kks ++ " cs=" ++ show (take 10 cs))+ ('\n', LS 0 kks cs) -- There are at least k leading spaces+ lead j (x:xs) | x == ' ' = lead (j-1) xs -- Count spaces+-- | x == '-' = ('\n', LS 0 kks cs)+ lead _ _ =+-- trace ("insert FS kks=" ++ show kks ++ " cs=" ++ show (take 10 cs))+ (fieldSep, LS 0 ks (c:cs)) -- Fewer than k spaces. Generate FS, pop, and try again.+ in lead (k+1) cs+ tmRawTokens (LS _ _ cs) = cs++skipEmpty :: String -> Maybe String+skipEmpty s =+ case dropWhile (== ' ') s of+ cs@('\n':_) -> Just cs+ _ -> Nothing++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+dropCabalComments :: String -> String+dropCabalComments = unlines . map cmt . lines+ where+ cmt s | take 2 (dropWhile (== ' ') s) == "--" = ""+ | otherwise = s++satisfySome :: String -> (Char -> Bool) -> P [Char]+satisfySome msg p = (:) <$> satisfy msg p <*> satisfyMany p++----------------------------------------------------------------++pCabalTop :: P Cabal+pCabalTop = pCabal <* pWhite <* pChar end++pCabal :: P Cabal+pCabal = Cabal <$> ((:) <$> (Section "global" "" <$> emany pField) <*> emany pSection)++pColon :: P ()+pColon = pWhite <* pChar ':'++pWhite :: P ()+pWhite = () <$ satisfyMany (\ c -> c == ' ' || c == '\n')++pChar :: Char -> P ()+pChar c = () <$ satisfy (show c) (c ==)++pFieldSep :: P ()+pFieldSep = pChar fieldSep++pNewLine :: P ()+pNewLine = pChar '\n'++pDot :: P ()+pDot = pChar '.'++pSpaces :: P ()+pSpaces = () <$ satisfyMany (== ' ')++pIdent :: P String+pIdent = do+ c <- satisfy "ident" isAlpha_+ cs <- satisfyMany isIdent+ pure (c:cs)++pKeyWordNC :: String -> P String+pKeyWordNC s = do+ pSpaces+ i <- pIdent+ guard (s == lower i)+ pure s++isIdent :: Char -> Bool+isIdent c = isAlphaNum c || c == '-' || c == '_' || c == '\'' || c == '.'++isAlpha_ :: Char -> Bool+isAlpha_ c = isAlpha c || c == '_'++pNumber :: P Int+pNumber = read <$> satisfySome "0..9" isDigit++pParens :: P a -> P a+pParens p = pStr "(" *> p <* pStr ")"++pVersion :: P Version+pVersion = pSpaces *> (makeVersion <$> esepBy1 pNumber pDot)++pVersionRange :: P VersionRange+pVersionRange = pVOr+ where+ pVOr = foldr1 VOr <$> esepBy1 pVAnd (pStr "&&")+ pVAnd = foldr1 VAnd <$> esepBy1 pVOp (pStr "||")+ pVOp = (pVOper <*> (pSpaces *> pVersion))+ <|< pParens pVersionRange+ <|< (pStr "==" *> pVEq)+ <|< (pStr "^>=" *> pVGEHat)+ pVEq = (VEQSet <$> pVSet) <|< do+ v <- pVersion+ (VEQWild v <$ pStr ".*") <|< pure (VEQ v)+ pVSet = (pStr "{" *> pCommaList pVersion <* pStr "}")+ pVGEHat = (VGEHat <$> pVersion) <|< (VGEHatSet <$> pVSet)++pVOper :: P (Version -> VersionRange)+pVOper = pSpaces *> choice [ VGT <$ pStr ">", VGT <$ pStr "<", VGT <$ pStr "<=", VGT <$ pStr ">="]++pStr :: String -> P ()+pStr s = pSpaces *> p s+ where p "" = pure ()+ p (c:cs) = pChar c *> p cs++pStrW :: String -> P ()+pStrW s = pWhite *> pStr s++pItem :: P Item+pItem = pWhite *> (pString <|< pWord)++-- A string in quotation marks.+pString :: P String+pString = do+ pChar '"'+ let achar = satisfy "char" (\ c -> c /= '\n' && c /= end && c /= fieldSep)+ loop r = do+ c <- achar+ if c == '"' then+ return $ reverse r+ else if c /= '\\' then+ loop (c:r)+ else do+ e <- achar+ let e' = fromMaybe e $ lookup e [('n', '\n'), ('t', '\t')] -- could have more+ loop (e' : r)+ loop []++pWord :: P Item+pWord = satisfySome "word" (\ c -> c `notElem` [' ', '\n', ',', end, fieldSep])++pComma :: P ()+pComma = pWhite *> pChar ','++pCommaList :: P a -> P [a]+pCommaList p = (pStr "," *> esepBy1 p pComma)+ <|< pCommaList' p++pCommaList' :: P a -> P [a]+pCommaList' p = esepBy p pComma <* eoptional (pStr ",")++pSpaceList :: P a -> P [a]+pSpaceList p = esepBy p pWhite++pOptCommaList :: P a -> P [a]+pOptCommaList p = --pSpaceList p <|> pCommaList 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)++pVComma :: P Value+pVComma = VItems <$> pCommaList pItem++pVSpace :: P Value+pVSpace = VItems <$> pSpaceList pItem++pVOptComma :: P Value+pVOptComma = VItems <$> pOptCommaList pItem++pVLibs :: P Value+pVLibs = VPkgs <$> pCommaList pPkg++pPkg :: P (Item, [Item], Maybe VersionRange)+pPkg = (,,) <$> pNameW <*> (pSpaces *> pLibs) <*> optional pVersionRange+ where+ pLibs = do+ pColon+ ((:[]) <$> pNameW) <|< (pStr "{" *> pCommaList pName <* pStr "}")+ <|<+ pure []+ pNameW = pWhite *> pIdent++pField :: P Field+pField = do+ pWhite+ pushColumn+ fn <- lower <$> pFieldName+-- traceM ("pFieldName fn=" ++ show fn)+ if fn == "if" then do+ c <- pCond+ pNewLine+ t <- emany pField+ pFieldSep+ e <- do+ pWhite+ pushColumn+ _ <- pKeyWordNC "else"+ fs <- emany pField+ pFieldSep+ pure fs+ <|<+ pure []+ pure $ If c t e+ else do+ pColon+ let p = getParser fn+ v <- p+ pFieldSep+-- traceM ("pField v=" ++ show v)+ pure $ Field fn v++pCond :: P Cond+pCond = pCor+ where+ 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))+ <|< (pKeyWordNC "flag" *> pParens (Cflag <$> pName))+ <|< (pKeyWordNC "impl" *> pParens (Cimpl <$> pName <*> optional pVersionRange))+ <|< (pKeyWordNC "os" *> pParens (Cos <$> pName))+ <|< pParens pCond++pFreeText :: P Value+pFreeText = do+ txt <- satisfyMany (\ c -> c /= end && c /= fieldSep)+ let dot "." = "" -- Single '.' used to make an empty line+ dot s = s+ pure $ VItem $ unlines . map (dot . dropWhile (== ' ')) . lines $ txt++pFieldName :: P FieldName+pFieldName = pIdent++pName :: P Name+pName = pSpaces *> pIdent++pFields :: P [Field]+pFields = pSpaces *> pNewLine *> emany pField++pBool :: P Bool+pBool = (False <$ pKeyWordNC "false") <|< (True <$ pKeyWordNC "true")++pSection :: P Section+pSection = pWhite *> (+ Section <$> pKeyWordNC "common" <*> pName <*> pFields+ <|< Section <$> pKeyWordNC "library" <*> libName <*> pFields+ <|< Section <$> pKeyWordNC "executable" <*> pName <*> pFields+ <|< Section <$> pKeyWordNC "source-repository" <*> pName <*> pFields+ <|< Section <$> pKeyWordNC "flag" <*> pName <*> pFields+ <|< Section <$> pKeyWordNC "test-suite" <*> pName <*> pFields+ )+ where libName = pName <|< pure ""++getParser :: FieldName -> P Value+getParser f =+ if "x-" `isPrefixOf` f then pFreeText else+ fromMaybe (error $ "Unknown field: " ++ f) $ lookup f parsers++parsers :: [(FieldName, P Value)]+parsers =+ [ "asm-options" # pVSpace+ , "asm-sources" # pVComma+ , "autogen-includes" # pVOptComma+ , "autogen-modules" # pVComma+ , "build-depends" # pVLibs+ , "build-tool-depends" # pVComma -- XXX+ , "build-tools" # pVComma -- XXX+ , "buildable" # (VBool <$> pBool)+ , "c-sources" # pVComma+ , "cc-options" # pVComma+ , "cmm-sources" # pVComma+ , "cmm-options" # pVComma+ , "cpp-options" # pVComma+ , "cxx-options" # pVComma+ , "default-extensions" # pVOptComma+ , "default-language" # (VItem <$> pItem)+ , "exposed-modules" # pVOptComma+ , "extensions" # pVOptComma+ , "extra-bundled-libraries" # pVComma+ , "extra-dynamic-library-flavours" # pVComma+ , "extra-framework-dirs" # pVComma+ , "extra-ghci-libraries" # pVComma+ , "extra-lib-dirs" # pVComma+ , "extra-lib-dirs-static" # pVComma+ , "extra-libraries" # pVComma+ , "frameworks" # pVOptComma+ , "ghc-options" # pVSpace+ , "ghc-prof-options" # pVSpace+ , "ghc-shared-options" # pVSpace+ , "ghcjs-options" # pVSpace+ , "ghcjs-prof-options" # pVSpace+ , "ghcjs-shared-options" # pVSpace+ , "hs-source-dirs" # pVOptComma+ , "import" # (VItem <$> pItem)+ , "include-dirs" # pVOptComma+ , "includes" # pVOptComma+ , "install-includes" # pVOptComma+ , "js-sources" # pVComma+ , "ld-options" # pVSpace+ , "mixins" # pFreeText -- XXX+ , "nhc98-options" # pVSpace+ , "other-extensions" # pVOptComma+ , "other-languages" # (VItem <$> pItem)+ , "other-modules" # pVOptComma+ , "pkg-config-depends" # pVComma+ , "virtual-modules" # pVComma+ --- library fields + , "visibility" # (VItem <$> pItem)+ --- package fields + , "author" # pFreeText+ , "bug-reports" # pFreeText+ , "build-type" # (VItem <$> pItem)+ , "cabal-version" # pFreeText -- (VRange <$> pVersionRange)+ , "category" # pFreeText+ , "copyright" # pFreeText+ , "data-dir" # pVSpace+ , "data-files" # pVComma+ , "description" # pFreeText+ , "extra-doc-files" # pVComma+ , "extra-source-files" # pVOptComma+ , "extra-tmp-files" # pVComma+ , "homepage" # pFreeText+ , "license" # pFreeText+ , "license-file" # pVOptComma+ , "license-files" # pVOptComma+ , "maintainer" # pFreeText+ , "name" # (VItem <$> pItem)+ , "package-url" # pFreeText+ , "stability" # pFreeText+ , "subdir" # pFreeText+ , "synopsis" # pFreeText+ , "tested-with" # pVOptComma+ , "version" # (VVersion <$> pVersion)+ -- test suite fields + , "main-is" # (VItem <$> pItem)+ , "test-module" # (VItem <$> pItem)+ , "type" # (VItem <$> pItem)+ -- source-repository fields+ , "location" # pFreeText+ -- flag fields+ , "manual" # (VBool <$> pBool)+ , "default" # (VBool <$> pBool)+ , "tag" # pFreeText+ ]+ 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)++pSnapshotsTop :: P [Snapshot]+pSnapshotsTop = pSnapshots <* pWhite <* pChar end++pSnapshots :: P [Snapshot]+pSnapshots = pWhite *> pChar '{' *> (esepBy pSnapshot (pWhite *> pChar ',')) <* pWhite <* pChar '}'++pSnapshot :: P Snapshot+pSnapshot = (,) <$> (pWhite *> pString) <*> (pWhite *> pChar ':' *> pWhite *> pString)
+ src/MicroCabal/StackageList.hs view
@@ -0,0 +1,70 @@+module MicroCabal.StackageList(+ StackageList,+ StackagePackage(..),+ PackageName, FlagName,+ showPackage,+ readPackage,+ yamlToStackageList,+ ) where+import Data.Maybe+import Data.Version+import Text.Read+import MicroCabal.YAML++type StackageList = [StackagePackage]+type PackageName = String+type FlagName = String++data StackagePackage = StackagePackage {+ stName :: PackageName,+ stVersion :: Version,+ stHidden :: Bool,+ stFlags :: [(FlagName, Bool)]+ }+ deriving (Show)++showPackage :: StackagePackage -> String+showPackage st = unwords $ stName st : showVersion (stVersion st) : show (stHidden st) : map flag (stFlags st)+ where flag (n,b) = n ++ "=" ++ show b++readPackage :: String -> StackagePackage+readPackage spkg =+ case words spkg of+ name : vers : hide : flgs ->+ StackagePackage { stName = name, stVersion = readVersion vers, stHidden = read hide, stFlags = map flag flgs }+ _ -> error "readPackage"+ where flag s = (n, read (drop 1 b)) where (n, b) = span (/= '=') s++yamlToStackageList :: YAMLValue -> [StackagePackage]+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) -> + map (addFlags flags . addHidden hidden . decodePackage) packages+ _ -> error "Unrecognized Stackage package list format"+yamlToStackageList _ = error "Unrecognized Stackage package list format"++addFlags :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage+addFlags flags st = maybe st (\ f -> st{ stFlags = yflags f }) $ lookup (stName st) flags+ where yflags (YRecord r) = [(n, b) | (n, YBool b) <- r]+ yflags _ = error "addFlags"++addHidden :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage+addHidden hidden st = maybe st (\ f -> st{ stHidden = ybool f }) $ lookup (stName st) hidden+ where ybool (YBool b) = b+ ybool _ = error "addHidden"++decodePackage :: YAMLValue -> StackagePackage+decodePackage (YRecord (("hackage", YString fs):_)) = StackagePackage { stName = n, stVersion = v, stHidden = False, stFlags = [] }+ where+ s = takeWhile (/= '@') fs+ (n, v) =+ case span (/= '-') (reverse s) of+ (rv, rn) -> (reverse (drop 1 rn), readVersion (reverse rv))+decodePackage y = error $ "Bad package desc " ++ show y++readVersion :: String -> Version+readVersion s = fromMaybe (error $ "decodePackage: bad version " ++ s) $ readVersionM s++readVersionM :: String -> Maybe Version+readVersionM s = makeVersion <$> (mapM readMaybe . words . map (\ c -> if c == '.' then ' ' else c) $ s)
+ src/MicroCabal/Unix.hs view
@@ -0,0 +1,76 @@+module MicroCabal.Unix(+ cmd, tryCmd, cmdOut,+ mkdir,+ wget, URL(..),+ tarx,+ rmrf,+ cp,+ copyFiles,+ ) where+import Control.Exception+import Control.Monad+import Data.Maybe+import System.Directory+import System.Environment+import System.IO+import System.Process(callCommand)+import MicroCabal.Env++newtype URL = URL String++cmd :: Env -> String -> IO ()+cmd env s = do+ when (verbose env > 1) $+ putStrLn $ "cmd: " ++ s+ callCommand s++tryCmd :: Env -> String -> IO Bool+tryCmd env s = catch (cmd env s >> return True) (\ (_ :: SomeException) -> return False)++cmdOut :: Env -> String -> IO String+cmdOut env s = do+ (fn, h) <- tmpFile+ hClose h+ cmd env $ s ++ ">" ++ fn+ o <- readFile fn+ removeFile fn+ return o++tmpFile :: IO (String, Handle)+tmpFile = do+ mtmp <- lookupEnv "TMPDIR"+ let tmp = fromMaybe "/tmp" mtmp+ tmplt = "mcabal.txt"+ res <- try $ openTempFile tmp tmplt+ case res of+ Right x -> return x+ Left (_::SomeException) -> openTempFile "." tmplt+++---------++-- Create a directory path, don't complain if it exists.+mkdir :: Env -> String -> IO ()+mkdir env d = cmd env $ "mkdir -p " ++ d++-- 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++-- Extract a tar file+tarx :: Env -> FilePath -> FilePath -> IO ()+tarx env dir file = cmd env $ "tar -C " ++ dir ++ " -x -f " ++ file++-- Recursively remove+rmrf :: Env -> FilePath -> IO ()+rmrf env fn = cmd env $ "rm -rf " ++ fn++-- Copy a file to a directory+cp :: Env -> FilePath -> FilePath -> IO ()+cp env s d = do+ cmd env $ "rm -f " ++ d+ cmd env $ "cp " ++ s ++ " " ++ d++copyFiles :: Env -> FilePath -> [FilePath] -> FilePath -> IO ()+copyFiles env src fns tgt = do+ cmd env $ "cd " ++ src ++ "; tar cf - " ++ unwords fns ++ " | (cd " ++ tgt ++ "; tar xf - )"
+ src/MicroCabal/YAML.hs view
@@ -0,0 +1,17 @@+module MicroCabal.YAML(+ YAMLValue(..),+ YAMLFieldName,+ showYAML,+ ) where+type YAMLFieldName = String++data YAMLValue+ = YString String+ | YBool Bool+ | YInt Int+ | YRecord [(YAMLFieldName, YAMLValue)]+ | YArray [YAMLValue]+ deriving (Show)++showYAML :: YAMLValue -> String+showYAML = show
+ src/Text/ParserComb.hs view
@@ -0,0 +1,206 @@+-- Copyright 2023 Lennart Augustsson+-- See LICENSE file for full license.+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# LANGUAGE FunctionalDependencies #-}+module Text.ParserComb(+ Prsr, runPrsr,+ satisfy, satisfyM,+ satisfyMany,+ choice,+ many, emany, optional, eoptional,+ some, esome,+ esepBy, sepBy1, esepBy1,+ esepEndBy, esepEndBy1,+ (<?>), (<|<),+ --notFollowedBy,+ --lookAhead,+ nextToken,+ LastFail(..),+ TokenMachine(..),+ mapTokenState,+ ) where+--Ximport Prelude()+import Prelude+import Control.Applicative+import Control.Monad++data LastFail t+ = LastFail Int [t] [String]+ deriving (Show)++maxInt :: Int+maxInt = 1000000000++noFail :: forall t . LastFail t+noFail = LastFail maxInt [] []++longest :: forall t . LastFail t -> LastFail t -> LastFail t+longest lf1@(LastFail l1 t1 x1) lf2@(LastFail l2 _ x2) =+ if l1 < l2 then+ lf1+ else if l2 < l1 then+ lf2+ else+ LastFail l1 t1 (x1 ++ x2)++longests :: forall t . [LastFail t] -> LastFail t+longests xs = foldl1 longest xs++class TokenMachine tm t | tm -> t where+ tmNextToken :: tm -> (t, tm)+ tmRawTokens :: tm -> [t]++tmLeft :: forall tm t . TokenMachine tm t => tm -> Int+tmLeft = length . tmRawTokens++firstToken :: forall tm t . TokenMachine tm t => tm -> [t]+firstToken tm =+ case tmNextToken tm of+ (t, _) -> [t]++data Res tm t a = Many [(a, tm)] (LastFail t)+ --deriving (Show)++data Prsr tm t a = P (tm -> Res tm t a)+--instance Show (Prsr s t a) where show _ = "<<Prsr>>"++runP :: forall tm t a . Prsr tm t a -> (tm -> Res tm t a)+runP (P p) = p++mapTokenState :: forall tm t . (tm -> tm) -> Prsr tm t ()+mapTokenState f = P (\ tm -> Many [((), f tm)] noFail)++instance forall tm t . Functor (Prsr tm t) where+ fmap f p = P $ \ t ->+ case runP p t of+ Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf++instance forall tm t . Applicative (Prsr tm t) where+ pure a = P $ \ t -> Many [(a, t)] noFail+ (<*>) = ap+ (*>) p k = p >>= \ _ -> k++instance forall tm t . Monad (Prsr tm t) where+ (>>=) p k = P $ \ t ->+ case runP p t of+ Many aus plf ->+ let ms = map (\ (a, u) -> runP (k a) u) aus+ lfs = map (\ (Many _ lf) -> lf) ms+ rrs = [ r | Many rs _ <- ms, r <- rs ]+ in Many rrs (longests (plf : lfs))+ return = pure++instance forall t tm . TokenMachine tm t => MonadFail (Prsr tm t) where+ fail m = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) [m])++instance forall t tm . TokenMachine tm t => Alternative (Prsr tm t) where+ empty = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) ["empty"])++ (<|>) p q = P $ \ t ->+ case runP p t of+ Many a lfa ->+ case runP q t of+ Many b lfb -> Many (a ++ b) (longest lfa lfb)++-- Left biased choice+infixl 3 <|<+(<|<) :: forall tm t a . Prsr tm t a -> Prsr tm t a -> Prsr tm t a+(<|<) p q = P $ \ t ->+ case runP p t of+ Many [] lfa ->+ case runP q t of+ Many b lfb -> Many b (longest lfa lfb)+ r -> r++satisfy :: forall tm t . TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t+satisfy msg f = P $ \ acs ->+ case tmNextToken acs of+ r@(c, _) | f c -> Many [r] noFail+ _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])++satisfyM :: forall tm t a . TokenMachine tm t => String -> (t -> Maybe a) -> Prsr tm t a+satisfyM msg f = P $ \ acs ->+ case tmNextToken acs of+ (c, cs) | Just a <- f c -> Many [(a, cs)] noFail+ _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])++satisfyMany :: forall tm t . TokenMachine tm t => (t -> Bool) -> Prsr tm t [t]+satisfyMany f = P $ loop []+ where loop res acs =+ case tmNextToken acs of+ (c, cs) | f c -> loop (c:res) cs+ | otherwise -> Many [(reverse res, acs)] noFail++infixl 9 <?>+(<?>) :: forall tm t a . Prsr tm t a -> String -> Prsr tm t a+(<?>) p e = P $ \ t ->+-- trace ("<?> " ++ show e) $+ case runP p t of+ Many rs (LastFail l ts _) -> Many rs (LastFail l ts [e])++{-+lookAhead :: forall tm t a . TokenMachine tm t => Prsr tm t a -> Prsr tm t ()+lookAhead p = P $ \ t ->+ case runP p t of+ Many [] (LastFail l ts xs) -> Many [] (LastFail l (take 1 ts) xs)+ _ -> Many [((), t)] noFail+-}++nextToken :: forall tm t . TokenMachine tm t => Prsr tm t t+nextToken = P $ \ cs ->+ case tmNextToken cs of+ (c, _) -> Many [(c, cs)] noFail++{-+eof :: forall tm t . TokenMachine tm t => Prsr tm t ()+eof = P $ \ t@(cs, _) ->+ case tmNextToken cs of+ Nothing -> Many [((), t)] noFail+ Just _ -> Many [] (LastFail (tmLeft cs) (firstToken cs) ["eof"])+-}++{-+notFollowedBy :: forall t a . Prsr t a -> Prsr t ()+notFollowedBy p = P $ \ t@(ts,_) ->+ case runP p t of+ Many [] _ -> Many [((), t)] noFail+ _ -> Many [] (LastFail (length ts) (take 1 ts) ["!"])+-}++runPrsr :: forall tm t a . --X(Show a, Show s) =>+ Prsr tm t a -> tm -> Either (LastFail t) [a]+runPrsr (P p) f =+ case p f of+ Many [] lf -> Left lf+ Many xs _ -> Right [a | (a, _) <- xs ]++-------------------------------++emany :: forall tm t a . Prsr tm t a -> Prsr tm t [a]+emany p = esome p <|< pure []++esome :: forall tm t a . Prsr tm t a -> Prsr tm t [a]+esome p = (:) <$> p <*> emany p++eoptional :: forall tm t a . Prsr tm t a -> Prsr tm t (Maybe a)+eoptional p = (Just <$> p) <|< pure Nothing++choice :: forall tm t a . TokenMachine tm t => [Prsr tm t a] -> Prsr tm t a+choice [] = empty+choice ps = foldr1 (<|>) ps++sepBy1 :: forall tm t a sep . TokenMachine tm t => Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+sepBy1 p sep = (:) <$> p <*> many (sep *> p)++esepBy1 :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepBy1 p sep = (:) <$> p <*> emany (sep *> p)++esepBy :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepBy p sep = esepBy1 p sep <|< pure []++esepEndBy :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepEndBy p sep = esepEndBy1 p sep <|< pure []++esepEndBy1 :: forall tm t a sep . Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]+esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure [])+