├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── LICENSE ├── Makefile ├── MicroCabal.cabal ├── README.md ├── TODO └── src ├── MicroCabal ├── Backend │ ├── GHC.hs │ └── MHS.hs ├── Cabal.hs ├── Env.hs ├── Glob.hs ├── Macros.hs ├── Main.hs ├── Normalize.hs ├── Parse.hs ├── Regex.hs ├── StackageList.hs ├── Unix.hs └── YAML.hs └── Text └── ParserComb.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v4 19 | - uses: actions/setup-haskell@v1 20 | with: 21 | ghc-version: '8.10.3' 22 | cabal-version: '3.2' 23 | 24 | - name: Cache 25 | uses: actions/cache@v3 26 | env: 27 | cache-name: cache-cabal 28 | with: 29 | path: ~/.cabal 30 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 31 | restore-keys: | 32 | ${{ runner.os }}-build-${{ env.cache-name }}- 33 | ${{ runner.os }}-build- 34 | ${{ runner.os }}- 35 | 36 | - name: Install dependencies 37 | run: | 38 | cabal update 39 | cabal build --only-dependencies 40 | - name: Build 41 | run: cabal build 42 | # - name: Run tests 43 | # run: cabal test all 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | bin/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | *~ 21 | .stack-work/ 22 | cabal.project.local 23 | cabal.project.local~ 24 | .HTF/ 25 | .ghc.environment.* 26 | .mhscache 27 | .mhsi 28 | Interactive.hs 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | Copyright Lennart Augustsson 2024 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MHSDIR=../MicroHs 2 | MHS=$(MHSDIR)/bin/mhs 3 | 4 | bin/mcabal: src/MicroCabal/*.hs src/MicroCabal/*/*.hs 5 | @mkdir -p bin 6 | MHSDIR=$(MHSDIR) $(MHS) -isrc -obin/mcabal MicroCabal.Main 7 | 8 | bin/gmcabal: src/MicroCabal/*.hs src/MicroCabal/*/*.hs 9 | @mkdir -p bin 10 | 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 11 | 12 | all: bin/gmcabal bin/mcabal 13 | 14 | clean: 15 | rm -rf ghc-out bin/* .mhscache 16 | cabal clean 17 | 18 | test: bin/mcabal 19 | bin/mcabal parse MicroCabal.cabal 20 | bin/mcabal parse ../MicroHs/MicroHs.cabal 21 | bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/polyparse-1.12/polyparse.cabal 22 | bin/mcabal parse ../MicroHs/cpphssrc/malcolm-wallace-universe/cpphs-1.20.9/cpphs.cabal 23 | bin/mcabal parse ../Hackage/optparse-applicative-0.18.1.0/optparse-applicative.cabal 24 | 25 | install: bin/mcabal 26 | @mkdir -p ~/.mcabal/bin 27 | cp bin/mcabal ~/.mcabal/bin 28 | -------------------------------------------------------------------------------- /MicroCabal.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: MicroCabal 3 | version: 0.5.1.0 4 | synopsis: A partial Cabal replacement 5 | license: Apache-2.0 6 | license-file: LICENSE 7 | copyright: 2024 Lennart Augustsson 8 | category: language 9 | author: lennart@augustsson.net 10 | maintainer: lennart@augustsson.net 11 | stability: experimental 12 | description: A portable subset of the Cabal functionality. 13 | build-type: Simple 14 | 15 | extra-source-files: 16 | LICENSE 17 | Makefile 18 | README.md 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/augustss/MicroCabal 23 | 24 | executable mcabal 25 | default-language: Haskell98 26 | hs-source-dirs: src 27 | ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -main-is MicroCabal.Main 28 | main-is: MicroCabal/Main.hs 29 | default-extensions: MultiParamTypeClasses ScopedTypeVariables PatternGuards 30 | other-modules: MicroCabal.Backend.GHC 31 | MicroCabal.Backend.MHS 32 | MicroCabal.Cabal 33 | MicroCabal.Env 34 | MicroCabal.Glob 35 | MicroCabal.Macros 36 | MicroCabal.Normalize 37 | MicroCabal.Parse 38 | MicroCabal.Regex 39 | MicroCabal.StackageList 40 | MicroCabal.Unix 41 | MicroCabal.YAML 42 | Text.ParserComb 43 | if impl(ghc) 44 | build-depends: base >= 4.10 && < 4.25, 45 | directory >= 1.3 && < 1.6, 46 | process >= 1.6 && < 1.9, 47 | if impl(mhs) 48 | build-depends: base >= 0.1 && < 10.0, 49 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MicroCabal 2 | This repository contains a reimplementation of a subset of Cabal. 3 | 4 | Why a reimplementation? Because Cabal is not a Haskell tool, it is a ghc tool. 5 | A Haskell tool should be compilable by an implementation of Haskell2010, 6 | which Cabal is definitely not. 7 | 8 | The implementation assumes a Unix-like system with commands like `wget` and `tar`. 9 | 10 | To get a consistent set of packages MicroCabal uses Stackage to find compatible packages. So in a sense, MicroCabal is more like a MicroStackage. 11 | 12 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Install data files, include files, etc. 2 | Add include dirs from installed packages to uses of it. 3 | 4 | * Test (with ghc) with lots of packages. 5 | 6 | * Cache compiler name&version 7 | -------------------------------------------------------------------------------- /src/MicroCabal/Backend/GHC.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Backend.GHC(ghcBackend) where 2 | import Control.Monad 3 | import Data.List 4 | import Data.Maybe 5 | import Data.Version 6 | import System.Directory 7 | import MicroCabal.Cabal 8 | import MicroCabal.Env 9 | import MicroCabal.Macros 10 | import MicroCabal.Parse(readVersion) 11 | import MicroCabal.Unix 12 | import System.Environment 13 | 14 | ghcBackend :: Env -> IO Backend 15 | ghcBackend env = do 16 | mghc <- lookupEnv "GHC" 17 | let exe = fromMaybe "ghc" mghc 18 | -- Actual GHC version. 19 | numVersion <- takeWhile (/= '\n') <$> cmdOut env (exe ++ " --numeric-version") 20 | -- GHC version used in the stackage snapshot. 21 | snapVersion <- readFile (cabalDir env "ghc-version") 22 | let ghcVersion = "ghc-" ++ numVersion 23 | version = readVersion numVersion 24 | -- Check that the ghc version is the one that the Stackage snapshot wants. 25 | when (snapVersion /= ghcVersion) $ 26 | error $ "The Stackage snapshot files are for " ++ snapVersion ++ ", but the current compiler is " ++ ghcVersion 27 | 28 | return Backend { 29 | compilerName = "ghc", 30 | compilerVersion = version, 31 | compiler = ghcVersion, 32 | compilerExe = exe, 33 | doesPkgExist = ghcExists, 34 | buildPkgExe = ghcBuildExe, 35 | buildPkgLib = ghcBuildLib, 36 | installPkgExe = ghcInstallExe, 37 | installPkgLib = ghcInstallLib 38 | } 39 | 40 | getGhcName :: Env -> IO FilePath 41 | getGhcName env = return $ compiler $ backend env 42 | 43 | getGhcDir :: Env -> IO FilePath 44 | getGhcDir env = (cabalDir env ) <$> getGhcName env 45 | 46 | getBuildDir :: Env -> IO FilePath 47 | getBuildDir env = do 48 | ghcName <- getGhcName env 49 | return $ distDir env "build" ghcName 50 | 51 | initDB :: Env -> IO () 52 | initDB env = do 53 | dir <- getGhcDir env 54 | b <- doesDirectoryExist dir 55 | when (not b) $ do 56 | message env 0 $ "Creating GHC package db " ++ dir 57 | cmd env $ "ghc-pkg init " ++ dir 58 | 59 | ghcExists :: Env -> PackageName -> IO Bool 60 | ghcExists env pkgname = do 61 | -- First try with globally installed GHC packages. 62 | ok <- tryCmd env $ "ghc-pkg describe >/dev/null 2>/dev/null " ++ pkgname 63 | if ok then 64 | return True 65 | else do 66 | -- Try with packages installed wikh mcabal 67 | dir <- getGhcDir env 68 | tryCmd env $ "ghc-pkg --package-db=" ++ dir ++ " describe >/dev/null 2>/dev/null " ++ pkgname 69 | 70 | setupStdArgs :: Env -> [Field] -> IO [String] 71 | setupStdArgs env flds = do 72 | db <- getGhcDir env 73 | let srcDirs = getFieldStrings flds ["."] "hs-source-dirs" 74 | defExts = getFieldStrings flds [] "default-extensions" 75 | exts = getFieldStrings flds defExts "extensions" 76 | opts = getFieldStrings flds [] "ghc-options" 77 | cppOpts = getFieldStrings flds [] "cpp-options" 78 | incDirs = getFieldStrings flds [] "include-dirs" 79 | mlang = getFieldStringM flds "default-language" 80 | deps = getBuildDependsPkg flds 81 | lang = maybe [] (\ s -> ["-X" ++ s]) mlang 82 | buildDir <- getBuildDir env 83 | depvers <- mapM (getPackageVersion env) deps 84 | let macros = genPkgVersionMacros (zip deps depvers) 85 | return $ 86 | [ "-package-env=-", 87 | "-package-db=" ++ db, 88 | "-outputdir=" ++ buildDir, 89 | "-w"] ++ 90 | map ("-i" ++) srcDirs ++ 91 | ["-i" ++ pathModuleDir env] ++ 92 | map ("-I" ++) incDirs ++ 93 | map ("-X" ++) exts ++ 94 | lang ++ 95 | map ("-package " ++) deps ++ 96 | opts ++ 97 | macros ++ 98 | cppOpts 99 | 100 | binGhc :: FilePath 101 | binGhc = "bin" "ghc" 102 | 103 | ghcBuildExe :: Env -> Section -> Section -> IO () 104 | ghcBuildExe env _ (Section _ name flds) = do 105 | initDB env 106 | let mainIs = getFieldString flds "main-is" 107 | srcDirs = getFieldStrings flds ["."] "hs-source-dirs" 108 | bin = distDir env binGhc name 109 | mkdir env $ distDir env binGhc 110 | mainIs' <- findMainIs env srcDirs mainIs 111 | stdArgs <- setupStdArgs env flds 112 | let args = unwords $ ["-O"] ++ stdArgs ++ ["-o", bin, "--make", mainIs'] ++ 113 | [ ">/dev/null" | verbose env <= 0 ] 114 | message env 0 $ "Building executable " ++ bin ++ " with ghc" 115 | ghc env args 116 | 117 | findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath 118 | findMainIs _ [] fn = error $ "cannot find " ++ show fn 119 | findMainIs env (d:ds) fn = do 120 | let fn' = d fn 121 | b <- doesFileExist fn' 122 | if b then 123 | return fn' 124 | else 125 | findMainIs env ds fn 126 | 127 | -- It can happen that there are no exposed modules. 128 | -- E.g., for a package only needed for certain versions. 129 | getExposedModules :: [Field] -> [String] 130 | getExposedModules flds = getFieldStrings flds [] "exposed-modules" 131 | 132 | getOtherModules :: [Field] -> [String] 133 | getOtherModules flds = getFieldStrings flds [] "other-modules" 134 | 135 | ghcBuildLib :: Env -> Section -> Section -> IO () 136 | ghcBuildLib env (Section _ _ glob) (Section _ name flds) = do 137 | initDB env 138 | stdArgs <- setupStdArgs env flds 139 | let emdls = getExposedModules flds 140 | omdls = getOtherModules flds 141 | mdls = emdls ++ omdls 142 | ver = getVersion glob "version" 143 | args = unwords $ ["-O"] ++ stdArgs ++ 144 | ["--make", "-no-link", "-this-unit-id", key ] ++ 145 | ["-fbuilding-cabal-package", "-static" ] ++ 146 | mdls ++ 147 | [ ">/dev/null" | verbose env <= 0 ] 148 | key = name ++ "-" ++ showVersion ver ++ "-mcabal" 149 | if null mdls then 150 | message env 0 $ "Building library " ++ name ++ " with ghc skipped, no modules" 151 | else do 152 | message env 0 $ "Building library " ++ name ++ " with ghc" 153 | ghc env args 154 | 155 | ghcInstallExe :: Env -> Section -> Section -> IO () 156 | ghcInstallExe env (Section _ _ _glob) (Section _ name _) = do 157 | let bin = distDir env ++ binGhc ++ name 158 | binDir = cabalDir env "bin" 159 | mkdir env binDir 160 | cpr env bin (binDir name) 161 | 162 | getPackageField :: String -> Env -> PackageName -> IO PackageName 163 | getPackageField fld env n = do 164 | mr <- tryCmdOut env $ "ghc-pkg field " ++ n ++ " " ++ fld ++ " 2>/dev/null" -- returns "fld: val" 165 | last . words <$> 166 | case mr of 167 | Just r -> return r 168 | Nothing -> do 169 | dir <- getGhcDir env 170 | cmdOut env ("ghc-pkg field --package-db=" ++ dir ++ " " ++ n ++ " " ++ fld) -- returns "fld: val" 171 | 172 | getPackageId :: Env -> PackageName -> IO PackageName 173 | getPackageId = getPackageField "id" 174 | 175 | getPackageVersion :: Env -> PackageName -> IO Version 176 | getPackageVersion env n = readVersion <$> getPackageField "version" env n 177 | 178 | ghcInstallLib :: Env -> Section -> Section -> IO () 179 | ghcInstallLib env (Section _ _ glob) (Section _ name flds) = do 180 | initDB env 181 | buildDir <- getBuildDir env 182 | ghcDir <- getGhcDir env 183 | let namever = name ++ "-" ++ showVersion vers 184 | destDir = ghcDir namever 185 | vers = getVersion glob "version" 186 | archOut = destDir "libHS" ++ namever ++ "-mcabal.a" 187 | mkdir env destDir 188 | rmrf env archOut 189 | 190 | let files = map mdlToHi (omdls ++ mdls) 191 | mdls = getExposedModules flds 192 | omdls = getOtherModules flds 193 | mdlToHi = (++ ".hi") . map (\ c -> if c == '.' then '/' else c) 194 | 195 | when (not (null files)) $ do 196 | cmd env $ "ar -c -r -s " ++ archOut ++ " `find " ++ buildDir ++ " -name '*.o'`" 197 | copyFiles env buildDir files destDir 198 | 199 | db <- getGhcDir env 200 | let extraLibs = getFieldStrings flds [] "extra-libraries" 201 | deps = getBuildDependsPkg flds 202 | depends <- nub <$> mapM (getPackageId env) deps 203 | let desc = unlines $ 204 | [ "name: " ++ name 205 | , "version: " ++ showVersion vers 206 | , "visibility: public" 207 | , "id: " ++ key 208 | , "key: " ++ key 209 | , "exposed: True" 210 | , "exposed-modules: " ++ unwords mdls 211 | , "import-dirs: " ++ destDir 212 | , "library-dirs: " ++ destDir 213 | , "library-dirs-static: " ++ destDir 214 | , "extra-libraries: " ++ unwords extraLibs 215 | , "depends: " ++ unwords depends 216 | ] ++ 217 | [ "hs-libraries: HS" ++ key | not (null files) ] 218 | key = namever ++ "-mcabal" 219 | pkgFn = db key ++ ".conf" 220 | quiet = if verbose env > 0 then "" else " >/dev/null" 221 | writeFile pkgFn desc 222 | cmd env $ "ghc-pkg update --package-db=" ++ db ++ " " ++ pkgFn ++ quiet 223 | 224 | ghc :: Env -> String -> IO () 225 | ghc env args = cmd env $ compilerExe (backend env) ++ " " ++ args 226 | 227 | --ghcOut :: Env -> String -> IO String 228 | --ghcOut env args = cmdOut env $ compilerExe (backend env) ++ " " ++ args 229 | 230 | -- XXX Should do above for ghc-pkg as well. 231 | -------------------------------------------------------------------------------- /src/MicroCabal/Backend/MHS.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Backend.MHS(mhsBackend) where 2 | import Control.Monad 3 | import Data.List(dropWhileEnd, (\\), stripPrefix) 4 | import Data.Maybe 5 | import Data.Version 6 | import System.Directory 7 | import MicroCabal.Cabal 8 | import MicroCabal.Env 9 | import MicroCabal.Macros 10 | import MicroCabal.Parse(readVersion) 11 | import MicroCabal.Unix 12 | import System.Environment 13 | 14 | mhsBackend :: Env -> IO Backend 15 | mhsBackend env = do 16 | mmhs <- lookupEnv "MHS" 17 | let exe = fromMaybe "mhs" mmhs 18 | numVersion <- takeWhile (/= '\n') <$> cmdOut env (exe ++ " --numeric-version") 19 | let mhsVersion = "mhs-" ++ numVersion 20 | version = readVersion numVersion 21 | return Backend { 22 | compilerName = "mhs", 23 | compilerVersion = version, 24 | compiler = mhsVersion, 25 | compilerExe = exe, 26 | doesPkgExist = mhsExists, 27 | buildPkgExe = mhsBuildExe, 28 | buildPkgLib = mhsBuildLib, 29 | installPkgExe = mhsInstallExe, 30 | installPkgLib = mhsInstallLib 31 | } 32 | 33 | mhsNameVers :: Env -> IO (String, Version) 34 | mhsNameVers env = do 35 | v <- readVersion . takeWhile (/= '\n') <$> mhsOut env "--numeric-version" 36 | return ("mhs", v) 37 | 38 | getMhsDir :: Env -> IO FilePath 39 | getMhsDir env = do 40 | (n, v) <- mhsNameVers env 41 | return $ cabalDir env ++ "/" ++ n ++ "-" ++ showVersion v 42 | 43 | initDB :: Env -> IO () 44 | initDB env = do 45 | dir <- getMhsDir env 46 | b <- doesDirectoryExist dir 47 | when (not b) $ do 48 | mkdir env (dir "packages") 49 | 50 | mhsExists :: Env -> PackageName -> IO Bool 51 | mhsExists _ pkgname | Just _ <- lookup pkgname builtinPackages = return True 52 | mhsExists env pkgname = do 53 | initDB env 54 | dir <- getMhsDir env 55 | pkgs <- listDirectory $ dir "packages" 56 | return $ any ((== pkgname) . init . dropWhileEnd (/= '-')) pkgs 57 | 58 | -- XXX These packages are part of mhs. 59 | -- The version numbers are totally fake. 60 | -- The version numbers are from GHC 9.8.2 61 | builtinPackages :: [(String, Version)] 62 | builtinPackages = [ 63 | ("array", makeVersion [0,5,6,0]), 64 | ("base", makeVersion [4,19,1,0]), 65 | ("deepseq", makeVersion [1,5,0,0]), 66 | ("directory", makeVersion [1,3,8,1]), 67 | ("hashable", makeVersion [1,0,0,0]), -- very rudimentary 68 | ("process", makeVersion [1,6,18,0]), 69 | ("bytestring",makeVersion [0,12,1,0]), 70 | ("text", makeVersion [2,1,1]) 71 | ] 72 | 73 | getPackageVersion :: Env -> String -> IO Version 74 | getPackageVersion _ pkgName | Just v <- lookup pkgName builtinPackages = return v 75 | getPackageVersion env pkgName = do 76 | dir <- getMhsDir env 77 | pkgs <- listDirectory (dir "packages") 78 | let n = pkgName ++ "-" 79 | case [ readVersion vers | p <- pkgs, Just verspkg <- [stripPrefix n p], Just vers <- [stripSuffix ".pkg" verspkg] ] of 80 | [v] -> return v 81 | [] -> error $ "Not installed: " ++ pkgName 82 | _ -> error $ "Multiple version: " ++ pkgName 83 | 84 | setupStdArgs :: Env -> [Field] -> IO [String] 85 | setupStdArgs env flds = do 86 | -- db <- getMhsDir env 87 | let srcDirs = getFieldStrings flds ["."] "hs-source-dirs" 88 | defExts = getFieldStrings flds [] "default-extensions" 89 | exts = getFieldStrings flds defExts "extensions" 90 | oexts = getFieldStrings flds [] "other-extensions" 91 | opts = getFieldStrings flds [] "mhs-options" 92 | cppOpts = getFieldStrings flds [] "cpp-options" 93 | incs = getFieldStrings flds [] "include-dirs" 94 | exts' = filter (`elem` mhsX) (exts ++ oexts) 95 | deps = getBuildDependsPkg flds 96 | mhsX = ["CPP"] 97 | depvers <- mapM (getPackageVersion env) deps 98 | let macros = genPkgVersionMacros (zip deps depvers) 99 | return $ ["-i"] ++ 100 | map ("-i" ++) srcDirs ++ 101 | ["-i" ++ pathModuleDir env] ++ 102 | map ("-X" ++) exts' ++ 103 | map ("-I" ++) incs ++ 104 | opts ++ 105 | macros ++ 106 | cppOpts 107 | 108 | binMhs :: String 109 | binMhs = "bin" "mhs" 110 | 111 | mhsBuildExe :: Env -> Section -> Section -> IO () 112 | mhsBuildExe env _ (Section _ name flds) = do 113 | initDB env 114 | let mainIs = getFieldString flds "main-is" 115 | srcDirs = getFieldStrings flds ["."] "hs-source-dirs" 116 | bin = distDir env binMhs name 117 | mkdir env $ distDir env binMhs 118 | mainIs' <- findMainIs env srcDirs mainIs 119 | stdArgs <- setupStdArgs env flds 120 | let args = unwords $ stdArgs ++ 121 | ["-a." 122 | ,"-o" ++ bin, mainIs'] 123 | message env 0 $ "Build " ++ bin ++ " with mhs" 124 | mhs env args 125 | 126 | mhs :: Env -> String -> IO () 127 | mhs env args = do 128 | let flg = if verbose env == 1 then "-l " else if verbose env > 1 then "-v " else "" 129 | cmd env $ compilerExe (backend env) ++ " " ++ flg ++ args 130 | 131 | mhsOut :: Env -> String -> IO String 132 | mhsOut env args = 133 | cmdOut env $ compilerExe (backend env) ++ " " ++ args 134 | 135 | findMainIs :: Env -> [FilePath] -> FilePath -> IO FilePath 136 | findMainIs _ [] fn = error $ "cannot find " ++ show fn 137 | findMainIs env (d:ds) fn = do 138 | let fn' = d fn 139 | b <- doesFileExist fn' 140 | if b then 141 | return fn' 142 | else 143 | findMainIs env ds fn 144 | 145 | mhsBuildLib :: Env -> Section -> Section -> IO () 146 | mhsBuildLib env (Section _ _ glob) (Section _ name flds) = do 147 | initDB env 148 | stdArgs <- setupStdArgs env flds 149 | let mdls = getFieldStrings flds (error "no exposed-modules") "exposed-modules" 150 | omdls = getFieldStrings flds [] "other-modules" 151 | vers = getVersion glob "version" 152 | namever = name ++ "-" ++ showVersion vers 153 | pkgfn = namever ++ ".pkg" 154 | args = unwords $ ["-P" ++ namever, 155 | "-o" ++ pkgfn] ++ 156 | stdArgs ++ 157 | ["-a."] ++ 158 | mdls 159 | isMdl (' ':_) = True -- Relies on -L output format 160 | isMdl _ = False 161 | mhs env args 162 | pkgmdls <- words . unlines . filter isMdl . lines <$> mhsOut env ("-L" ++ pkgfn) 163 | let bad = pkgmdls \\ (mdls ++ omdls) 164 | when (not (null bad)) $ do 165 | message env (-1) "Warning: package modules not mentioned in exposed-modules nor other-modules" 166 | mapM_ (message env (-1)) bad 167 | 168 | mhsInstallExe :: Env -> Section -> Section -> IO () 169 | mhsInstallExe env (Section _ _ _glob) (Section _ name _) = do 170 | let bin = distDir env binMhs name 171 | binDir = cabalDir env "bin" 172 | mkdir env binDir 173 | cpr env bin (binDir name) 174 | 175 | mhsInstallLib :: Env -> Section -> Section -> IO () 176 | mhsInstallLib env (Section _ _ glob) (Section _ name _) = do 177 | initDB env 178 | let vers = getVersion glob "version" 179 | namever = name ++ "-" ++ showVersion vers 180 | mhs env $ "-Q " ++ namever ++ ".pkg" 181 | 182 | --- 183 | -- XXX 184 | stripSuffix :: String -> String -> Maybe String 185 | stripSuffix suf str = reverse <$> stripPrefix (reverse suf) (reverse str) 186 | -------------------------------------------------------------------------------- /src/MicroCabal/Cabal.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Cabal( 2 | Version(..), makeVersion, 3 | FieldName, Name, 4 | Cabal(..), 5 | Value(..), 6 | Field(..), 7 | Cond(..), 8 | Section(..), 9 | SectionType, 10 | VersionRange(..), 11 | Item, 12 | FlagInfo(..), 13 | showCabal, showSection, 14 | getFieldBool, 15 | getFieldString, 16 | getFieldStringM, 17 | getFieldStrings, 18 | getBuildDepends, 19 | getBuildDependsPkg, 20 | getVersion, 21 | ) where 22 | import Data.Maybe 23 | import Data.Version 24 | 25 | --type ExecName = String 26 | type FieldName = String 27 | type Name = String 28 | 29 | newtype Cabal = Cabal [Section] 30 | deriving (Show) 31 | 32 | data Value 33 | = VItems [Item] 34 | | VItem Item 35 | | VBool Bool 36 | | VVersion Version 37 | | VRange VersionRange 38 | | VPkgs [(Item, [Item], Maybe VersionRange)] 39 | | VXItem String -- for x-* fields 40 | deriving (Show) 41 | 42 | data Field 43 | = Field FieldName Value 44 | | If Cond [Field] [Field] 45 | deriving (Show) 46 | 47 | data Cond 48 | = CBool Bool 49 | | Cos Item 50 | | Carch Item 51 | | Cimpl Item (Maybe VersionRange) 52 | | Cflag Item 53 | | Cnot Cond 54 | | Cand Cond Cond 55 | | Cor Cond Cond 56 | deriving (Show) 57 | 58 | data Section = Section SectionType Name [Field] 59 | deriving (Show) 60 | 61 | type SectionType = String 62 | 63 | data VersionRange 64 | = VEQ Version 65 | | VGT Version 66 | | VLT Version 67 | | VLE Version 68 | | VGE Version 69 | | VGEHat Version 70 | | VEQWild Version 71 | | VOr VersionRange VersionRange 72 | | VAnd VersionRange VersionRange 73 | | VEQSet [Version] 74 | | VGEHatSet [Version] 75 | deriving (Show) 76 | 77 | type Item = String 78 | 79 | data FlagInfo = FlagInfo 80 | { os :: String 81 | , arch :: String 82 | , impl :: (String, Version) 83 | , flags :: [(Name, Bool)] 84 | } 85 | deriving (Show) 86 | 87 | showCabal :: Cabal -> String 88 | showCabal (Cabal sects) = 89 | "Cabal\n" ++ unlines (map showSection sects) 90 | 91 | showField :: Field -> String 92 | showField (Field n v) = " Field " ++ n ++ ": " ++ show v 93 | showField (If c t e) = 94 | " If " ++ show c ++ "\n" ++ 95 | unlines (map (indent . showField) t) ++ 96 | if null e then "" else 97 | " Else\n" ++ 98 | unlines (map (indent . showField) e) 99 | 100 | indent :: String -> String 101 | indent s = " " ++ concatMap (\ c -> if c == '\n' then "\n " else [c]) s 102 | 103 | showSection :: Section -> String 104 | showSection (Section s n fs) = unlines $ (" " ++ s ++ " " ++ n) : map (indent . showField) fs 105 | 106 | getFieldBool :: Bool -> [Field] -> FieldName -> Bool 107 | getFieldBool dflt flds name = 108 | case [ b | Field n (VBool b) <- flds, n == name ] of 109 | [b] -> b 110 | _ -> dflt 111 | 112 | getFieldString :: [Field] -> FieldName -> String 113 | getFieldString flds n = 114 | fromMaybe (error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds)) $ 115 | getFieldStringM flds n 116 | 117 | getFieldStringM :: [Field] -> FieldName -> Maybe String 118 | getFieldStringM flds n = 119 | case [ s | Field f (VItem s) <- flds, f == n ] of 120 | [] -> Nothing 121 | ss -> Just (last ss) 122 | 123 | getFieldStrings :: [Field] -> [String] -> FieldName -> [String] 124 | getFieldStrings flds def n = 125 | case [ ss | Field f (VItems ss) <- flds, f == n ] of 126 | [ss] -> ss 127 | _ -> def 128 | 129 | getBuildDepends :: [Field] -> [(Item, [Item], Maybe VersionRange)] 130 | getBuildDepends fs = 131 | case [ d | Field "build-depends" (VPkgs d) <- fs ] of 132 | [d] -> d 133 | _ -> [] 134 | 135 | getBuildDependsPkg :: [Field] -> [String] 136 | getBuildDependsPkg = map (\ (p,_,_) -> p) . getBuildDepends 137 | 138 | getVersion :: [Field] -> String -> Version 139 | getVersion flds n = 140 | case [ s | Field f (VVersion s) <- flds, f == n ] of 141 | [s] -> s 142 | _ -> error $ "field not found: " ++ show n ++ "\n" ++ unlines (map showField flds) 143 | -------------------------------------------------------------------------------- /src/MicroCabal/Env.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Env( 2 | Env(..), 3 | Target(..), 4 | Backend(..), 5 | backendNameVers, 6 | PackageName, 7 | message, 8 | pathModuleDir, 9 | ) where 10 | import MicroCabal.Cabal 11 | import MicroCabal.StackageList(PackageName) 12 | 13 | data Env = Env { 14 | cabalDir :: FilePath, -- where to install, default is $HOME/.mcabal 15 | distDir :: FilePath, -- where to build, default is dist-mcabal 16 | verbose :: Int, -- how chatty, default is 0, -1=say nothing, 0=minimal messages, 1=debug info 17 | depth :: Int, -- nesting depth for recursive builds, default is 0 18 | recursive:: Bool, -- do recursive builds, default is False 19 | eflags :: [(String, Bool)], -- Cabal flags 20 | backend :: Backend, -- which compiler to use, default is MHS 21 | targets :: [Target] -- only build/install these 22 | } 23 | 24 | data Target = TgtLib | TgtExe 25 | deriving (Eq) 26 | 27 | data Backend = Backend { 28 | compilerName :: String, -- just the name, e.g., "ghc", "mhs" 29 | compilerVersion:: Version, -- numeric version, e.g., makeVersion [9,8,2] 30 | compiler :: String, -- name&version, e.g., "ghc-9.8.2" 31 | compilerExe :: String, -- name of binary 32 | doesPkgExist :: Env -> PackageName -> IO Bool, -- is the package available in the database? 33 | buildPkgExe :: Env -> Section -> Section -> IO (), -- build executable the current directory 34 | buildPkgLib :: Env -> Section -> Section -> IO (), -- build the package in the current directory 35 | installPkgExe :: Env -> Section -> Section -> IO (), -- install the package from the current directory 36 | installPkgLib :: Env -> Section -> Section -> IO () -- install the package from the current directory 37 | } 38 | 39 | backendNameVers :: Backend -> (String, Version) 40 | backendNameVers b = (compilerName b, compilerVersion b) 41 | 42 | message :: Env -> Int -> String -> IO () 43 | message env level msg | verbose env >= level = putStrLn $ "mcabal: " ++ replicate (2 * depth env) ' ' ++ msg 44 | | otherwise = return () 45 | 46 | pathModuleDir :: Env -> FilePath 47 | pathModuleDir env = distDir env ++ "/" ++ "autogen" 48 | -------------------------------------------------------------------------------- /src/MicroCabal/Glob.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Glob( 2 | GlobPattern, 3 | --glob, 4 | listDirectoryRecursive, 5 | matchFiles, 6 | ) where 7 | import Control.Exception 8 | import Control.Monad 9 | import System.Directory 10 | import MicroCabal.Regex 11 | import MicroCabal.Unix(()) 12 | 13 | -- A glob pattern can contain: 14 | -- * - any number of file name characters, except / 15 | -- ** - any number of file name characters 16 | -- X - anything else is a character that just matches itself 17 | type GlobPattern = String 18 | 19 | {- 20 | glob :: GlobPattern -> [String] -> [String] 21 | glob p ss = 22 | let r = globToRegex p 23 | in filter (regexMatch r) ss 24 | -} 25 | 26 | globToRegex :: GlobPattern -> Regex 27 | globToRegex [] = eps 28 | globToRegex ('*':'*':cs) = Star (Lit (Neg "")) `Seq` globToRegex cs 29 | globToRegex ('*':cs) = Star (Lit (Neg "/")) `Seq` globToRegex cs 30 | globToRegex (c:cs) = Lit (Pos [c]) `Seq` globToRegex cs 31 | 32 | -- Recursively find all files in the given directory. 33 | listDirectoryRecursive :: FilePath -> IO [FilePath] 34 | listDirectoryRecursive ".git" = return [] -- Hack to avoid the gazillion files in .git/ 35 | listDirectoryRecursive x = do 36 | xs <- listDirectory x `catch` (\ (_ :: SomeException) -> return []) 37 | concat <$> (forM xs $ \ y -> (y:) <$> fmap (y ) <$> listDirectoryRecursive (x y)) 38 | 39 | matchFiles :: FilePath -> [GlobPattern] -> IO [FilePath] 40 | matchFiles dir pats = do 41 | fs <- listDirectoryRecursive dir 42 | let select pat = 43 | let re = globToRegex pat 44 | in filter (regexMatch re) fs 45 | pure $ concatMap select pats 46 | -------------------------------------------------------------------------------- /src/MicroCabal/Macros.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 2 | module MicroCabal.Macros(genPkgVersionMacros) where 3 | import Data.Version 4 | 5 | genPkgVersionMacros :: [(String, Version)] -> [String] 6 | genPkgVersionMacros pkgs = 7 | concatMap (\ (name, vers) -> generateMacros (map fixchar name) vers) pkgs 8 | where 9 | fixchar '-' = '_' 10 | fixchar c = c 11 | 12 | generateMacros :: String -> Version -> [String] 13 | generateMacros name version = 14 | [ concat [ "'-DVERSION_", name, "=", show (showVersion version), "'" ] 15 | , concat [ "'-DMIN_VERSION_", name, "(x,y,z)=(" 16 | , "(x)<", major1, "||" 17 | , "(x)==", major1, "&&(y)<", major2, "||" 18 | , "(x)==", major1, "&&(y)==", major2, "&&(z)<=", minor 19 | , ")'" 20 | ] 21 | ] 22 | where 23 | (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) 24 | -------------------------------------------------------------------------------- /src/MicroCabal/Main.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Main where 2 | import Control.Monad 3 | import Data.List 4 | import Data.Maybe 5 | import Data.Version 6 | import System.Environment 7 | import System.Exit 8 | import System.Directory 9 | import qualified System.Info as I 10 | --import Text.Read 11 | import MicroCabal.Backend.GHC 12 | import MicroCabal.Backend.MHS 13 | import MicroCabal.Cabal 14 | import MicroCabal.Env 15 | import MicroCabal.Glob 16 | import MicroCabal.Normalize 17 | import MicroCabal.Parse 18 | import MicroCabal.StackageList 19 | import MicroCabal.Unix 20 | --import MicroCabal.YAML 21 | 22 | version :: String 23 | version = "MicroCabal 0.5.1.0" 24 | 25 | main :: IO () 26 | main = do 27 | (env, args) <- decodeCommonArgs =<< setupEnv 28 | 29 | case args of 30 | [] -> usage 31 | ["--version"] -> putStrLn version 32 | "build" : as -> cmdBuild env as 33 | "clean" : as -> cmdClean env as 34 | "fetch" : as -> cmdFetch env as 35 | "help" : as -> cmdHelp env as 36 | "install" : as -> cmdInstall env as 37 | "parse" : as -> cmdParse env as 38 | "update" : as -> cmdUpdate env as 39 | _ -> usage 40 | 41 | setupEnv :: IO Env 42 | setupEnv = do 43 | cdirm <- lookupEnv "CABALDIR" 44 | home <- getEnv "HOME" 45 | let cdir = fromMaybe (home ".mcabal") cdirm 46 | env = Env{ cabalDir = cdir, distDir = "dist-mcabal", verbose = 0, depth = 0, eflags = [], 47 | backend = error "backend undefined", recursive = False, targets = [TgtLib, TgtExe] } 48 | be <- mhsBackend env 49 | return env{ backend = be } 50 | 51 | decodeCommonArgs :: Env -> IO (Env, [String]) 52 | decodeCommonArgs env = do 53 | let loop e ("-v" : as) = loop e{ verbose = verbose e + 1 } as 54 | loop e ("-q" : as) = loop e{ verbose = -1 } as 55 | loop e ("-r" : as) = loop e{ recursive = True } as 56 | loop e (('-':'f':s) : as) = loop e{ eflags = decodeCabalFlags s } as 57 | loop e ("--ghc" : as) = do be <- ghcBackend env; loop e{ backend = be } as 58 | loop e ("--mhs" : as) = do be <- mhsBackend env; loop e{ backend = be } as 59 | loop e as = return (e, as) 60 | loop env =<< getArgs 61 | 62 | decodeCabalFlags :: String -> [(Name, Bool)] 63 | decodeCabalFlags = map f . words 64 | where f ('-':s) = (s, False) 65 | f s = (s, True) 66 | 67 | usage :: IO () 68 | usage = do 69 | env <- setupEnv 70 | cmdHelp env [] 71 | exitWith (ExitFailure 1) 72 | 73 | ----------------------------------------- 74 | 75 | -- Package list 76 | packageListName :: FilePath 77 | packageListName = "packages.txt" 78 | 79 | -- Local name for snapshot list 80 | snapshotsName :: FilePath 81 | snapshotsName = "snapshots.json" 82 | 83 | -- Local name for snapshot 84 | snapshotName :: FilePath 85 | snapshotName = "snapshot.yaml" 86 | 87 | -- Name of the nightly snapshot 88 | nightlyName :: String 89 | nightlyName = "nightly" 90 | 91 | -- This is a JSON document enumerating all releases. 92 | stackageSourceList :: URL 93 | stackageSourceList = URL "https://stackage-haddock.haskell.org/snapshots.json" 94 | 95 | -- prefix of URL for actual snapshot 96 | snapshotSource :: String 97 | snapshotSource = "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" -- lts/22/13.yaml 98 | 99 | -- XXX This needs improvement 100 | getBestStackage :: Env -> IO URL 101 | getBestStackage env = do 102 | -- Get source list 103 | let dir = cabalDir env 104 | fsnaps = dir snapshotsName 105 | wget env stackageSourceList fsnaps 106 | file <- readFile fsnaps 107 | let snaps = parseSnapshots fsnaps file 108 | {- 109 | -- Pick LTS snapshot 110 | snap = snd $ last $ 111 | [(0::Int, error "no lts snapshots found")] ++ 112 | sort [ (l, r) | (lp, r) <- snaps, Just l <- [stripPrefix "lts-" lp >>= readMaybe] ] 113 | snap' = map (\ c -> if c == '-' || c == '.' then '/' else c) snap 114 | snapURL = URL $ snapshotSource ++ snap' ++ ".yaml" 115 | -} 116 | -- Pick a nightly snapshot 117 | snap = fromMaybe (error "no nightly snapshot found") $ lookup nightlyName snaps 118 | snap' = fixLeading0 $ map (\ c -> if c == '-' then '/' else c) snap 119 | fixLeading0 ('/':'0':cs) = '/' : fixLeading0 cs 120 | fixLeading0 (c:cs) = c : fixLeading0 cs 121 | fixLeading0 cs = cs 122 | snapURL = URL $ snapshotSource ++ snap' ++ ".yaml" 123 | message env 1 $ "Picking Stackage snapshot " ++ snap 124 | return $ snapURL 125 | 126 | cmdUpdate :: Env -> [String] -> IO () 127 | cmdUpdate env [] = do 128 | message env 0 "Retrieving Stackage package list" 129 | let dir = cabalDir env 130 | stk = dir snapshotName 131 | fpkgs = dir packageListName 132 | mkdir env dir 133 | url <- getBestStackage env 134 | wget env url stk 135 | file <- readFile stk 136 | let yml = parseYAML stk file 137 | pkgs = yamlToStackageList yml 138 | ghcVersion = yamlToGHCVersion yml 139 | -- putStrLn $ "==== " ++ ghcVersion 140 | -- putStrLn $ showYAML yml 141 | -- putStrLn $ show pkgs 142 | message env 1 $ "Write package list to " ++ fpkgs 143 | writeFile fpkgs $ unlines $ map showPackage $ pkgs ++ distPkgs 144 | writeFile (dir "ghc-version") ghcVersion 145 | cmdUpdate _ _ = usage 146 | 147 | -- These packages are part of the ghc distribution, so they are 148 | -- not in the stackage list. 149 | -- XXX What to do about versions? 150 | -- XXX more... 151 | -- Should get these from global-hints (?) 152 | distPkgs :: [StackagePackage] 153 | distPkgs = 154 | [ StackagePackage "containers" (makeVersion [0,8]) False [] 155 | , StackagePackage "deepseq" (makeVersion [1,5,0,0]) False [] 156 | , StackagePackage "mtl" (makeVersion [2,3,1]) False [] 157 | , StackagePackage "time" (makeVersion [1,12,2]) False [] 158 | , StackagePackage "transformers" (makeVersion [0,6,1,2]) False [] 159 | ] 160 | 161 | ----------------------------------------- 162 | 163 | hackageSrcURL :: String 164 | hackageSrcURL = "https://hackage.haskell.org/package/" 165 | 166 | getPackageList :: Env -> IO [StackagePackage] 167 | getPackageList env = do 168 | let dir = cabalDir env 169 | fpkgs = dir packageListName 170 | b <- doesFileExist fpkgs 171 | when (not b) $ do 172 | message env 0 "No package list, running 'update' command" 173 | cmdUpdate env [] 174 | map readPackage . lines <$> readFile fpkgs 175 | 176 | getPackageInfo :: Env -> PackageName -> IO StackagePackage 177 | getPackageInfo env pkg = do 178 | pkgs <- getPackageList env 179 | return $ fromMaybe (error $ "getPackageInfo: no package " ++ pkg) $ listToMaybe $ filter ((== pkg) . stName) pkgs 180 | 181 | dirPackage :: Env -> FilePath 182 | dirPackage env = cabalDir env "packages" 183 | 184 | dirForPackage :: Env -> StackagePackage -> FilePath 185 | dirForPackage env st = dirPackage env stName st ++ "-" ++ showVersion (stVersion st) 186 | 187 | cmdFetch :: Env -> [String] -> IO () 188 | cmdFetch env [pkg] = do 189 | st <- getPackageInfo env pkg 190 | let pkgs = stName st ++ "-" ++ showVersion (stVersion st) 191 | url = URL $ hackageSrcURL ++ pkgs pkgz 192 | pkgz = pkgs ++ ".tar.gz" 193 | pdir = dirForPackage env st 194 | file = pdir ++ ".tar.gz" 195 | b <- doesDirectoryExist pdir 196 | if b then 197 | message env 1 $ "Already in " ++ pdir 198 | else do 199 | mkdir env pdir 200 | message env 1 $ "Fetching " ++ pkgz 201 | wget env url file 202 | message env 1 $ "Unpacking " ++ pkgz ++ " in " ++ pdir 203 | tarx env (dirPackage env) file 204 | cmdFetch _ _ = usage 205 | 206 | ----------------------------------------- 207 | 208 | findCabalFile :: Env -> IO FilePath 209 | findCabalFile _env = do 210 | ns <- listDirectory "." 211 | case filter (".cabal" `isSuffixOf`) ns of 212 | [] -> error "no PKG.cabal file" 213 | [n] -> return n 214 | _ -> error "multiple PKG.cabal file" 215 | 216 | cmdBuild :: Env -> [String] -> IO () 217 | cmdBuild env [] = build env 218 | cmdBuild env [pkg] = do 219 | message env 0 $ "Build package " ++ pkg 220 | st <- getPackageInfo env pkg 221 | let dir = dirForPackage env st 222 | b <- doesDirectoryExist dir 223 | when (not b) $ do 224 | message env 0 $ "Package not found, running 'fetch " ++ pkg ++ "'" 225 | cmdFetch env [pkg] 226 | message env 0 $ "Building in " ++ dir 227 | setCurrentDirectory dir 228 | cmdBuild env [] 229 | cmdBuild _ _ = usage 230 | 231 | getGlobal :: Cabal -> Section 232 | getGlobal (Cabal sects) = 233 | fromMaybe (error "no global section") $ listToMaybe [ s | s@(Section "global" _ _) <- sects ] 234 | 235 | makeDataPrefix :: Env -> Section -> Section -> FilePath 236 | makeDataPrefix env (Section _ _ glob) (Section _ name _) = 237 | let vers = getVersion glob "version" 238 | pkgVers = name ++ "-" ++ showVersion vers 239 | dataPrefix = cabalDir env compiler (backend env) "packages" pkgVers 240 | in dataPrefix 241 | 242 | createPathFile :: Env -> Section -> Section -> IO () 243 | createPathFile env gsect@(Section _ _ glob) sect = do 244 | let vers = getVersion glob "version" 245 | name = getFieldString glob "name" 246 | mdlName = "Paths_" ++ map (\ c -> if c == '-' then '_' else c) name 247 | pathName = pathModuleDir env mdlName ++ ".hs" 248 | dataPrefix = makeDataPrefix env gsect sect 249 | dataDir = dataPrefix "data" 250 | message env 1 $ "Creating path module " ++ pathName 251 | mkdir env (pathModuleDir env) 252 | writeFile pathName $ 253 | "module " ++ mdlName ++ " where\n" ++ 254 | "import Data.Version\n" ++ 255 | "version :: Version; version = makeVersion " ++ show (versionBranch vers) ++ "\n" ++ 256 | "getDataDir :: IO FilePath; getDataDir = return " ++ show dataDir ++ "\n" 257 | 258 | build :: Env -> IO () 259 | build env = do 260 | fn <- findCabalFile env 261 | rfile <- readFile fn 262 | let comp = backendNameVers (backend env) 263 | let cbl = parseCabal fn rfile 264 | info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } 265 | ncbl@(Cabal sects) = normalize info cbl 266 | glob = getGlobal ncbl 267 | sect s@(Section "executable" _ _) | TgtExe `elem` targets env && isBuildable s = buildExe env glob s 268 | sect s@(Section "library" _ _) | TgtLib `elem` targets env && isBuildable s = buildLib env glob s 269 | sect _ = return () 270 | message env 3 $ "Unnormalized Cabal file:\n" ++ show cbl 271 | message env 2 $ "Normalized Cabal file:\n" ++ show ncbl 272 | mapM_ sect $ addMissing sects 273 | 274 | isBuildable :: Section -> Bool 275 | isBuildable (Section _ _ flds) = getFieldBool True flds "buildable" 276 | 277 | buildExe :: Env -> Section -> Section -> IO () 278 | buildExe env glob sect@(Section _ name flds) = do 279 | message env 0 $ "Building executable " ++ name 280 | createPathFile env glob sect 281 | let deps = getBuildDepends flds 282 | pkgs = [ p | (p, _, _) <- deps ] 283 | mapM_ (checkDep env) pkgs 284 | buildPkgExe (backend env) env glob sect 285 | 286 | buildLib :: Env -> Section -> Section -> IO () 287 | buildLib env glob sect@(Section _ name flds) = do 288 | message env 0 $ "Building library " ++ name 289 | createPathFile env glob sect 290 | let pkgs = getBuildDependsPkg flds 291 | mapM_ (checkDep env) pkgs 292 | buildPkgLib (backend env) env glob sect 293 | 294 | checkDep :: Env -> PackageName -> IO () 295 | checkDep env pkg = do 296 | let bend = backend env 297 | b <- doesPkgExist bend env pkg 298 | when (not b) $ 299 | if recursive env then do 300 | let env' = env { depth = depth env + 1 } 301 | preserveCurrentDirectory $ 302 | cmdInstallLib env' [pkg] 303 | else 304 | error $ "dependency not installed: " ++ pkg 305 | 306 | -- If there is no section, except the global one, then just make a 307 | -- library section. 308 | addMissing :: [Section] -> [Section] 309 | addMissing [glb@(Section "global" _ flds)] = [glb, Section "library" (getFieldString flds "name") flds] 310 | addMissing sects = sects 311 | 312 | ----------------------------------------- 313 | 314 | cmdInstall :: Env -> [String] -> IO () 315 | cmdInstall env args = do 316 | -- The will build and change current directory 317 | cmdBuild env args 318 | install env 319 | 320 | cmdInstallLib :: Env -> [String] -> IO () 321 | cmdInstallLib env args = cmdInstall env{ targets = [TgtLib] } args 322 | 323 | install :: Env -> IO () 324 | install env = do 325 | fn <- findCabalFile env 326 | rfile <- readFile fn 327 | let comp = backendNameVers (backend env) 328 | let cbl = parseCabal fn rfile 329 | info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } 330 | ncbl@(Cabal sects) = normalize info cbl 331 | glob = getGlobal ncbl 332 | sect s@(Section "executable" _ _) | TgtExe `elem` targets env && isBuildable s = installExe env glob s 333 | sect s@(Section "library" _ _) | TgtLib `elem` targets env && isBuildable s = installLib env glob s 334 | sect _ = return () 335 | message env 3 $ "Unnormalized Cabal file:\n" ++ show cbl 336 | message env 2 $ "Normalized Cabal file:\n" ++ show ncbl 337 | mapM_ sect $ addMissing sects 338 | 339 | installExe :: Env -> Section -> Section -> IO () 340 | installExe env glob sect@(Section _ name _) = do 341 | message env 0 $ "Installing executable " ++ name 342 | installDataFiles env glob sect 343 | installIncludeFiles env glob sect 344 | installCFiles env glob sect 345 | installPkgExe (backend env) env glob sect 346 | 347 | installLib :: Env -> Section -> Section -> IO () 348 | installLib env glob sect@(Section _ name _) = do 349 | message env 0 $ "Installing library " ++ name 350 | installDataFiles env glob sect 351 | installIncludeFiles env glob sect 352 | installCFiles env glob sect 353 | installPkgLib (backend env) env glob sect 354 | 355 | installDataFiles :: Env -> Section -> Section -> IO () 356 | installDataFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do 357 | let gdatas = getFieldStrings gflds [] "data-files" 358 | datas = getFieldStrings flds [] "data-files" 359 | dataPrefix = makeDataPrefix env glob sect 360 | dataDir = dataPrefix "data" 361 | --print ("installDataFiles", gdatas ++ datas, dataDir) 362 | case gdatas ++ datas of 363 | [] -> return () 364 | pats -> do 365 | files <- matchFiles "." pats 366 | message env 1 $ "Installing data files " ++ unwords files 367 | mkdir env dataDir 368 | copyFiles env "." files dataDir 369 | 370 | installIncludeFiles :: Env -> Section -> Section -> IO () 371 | installIncludeFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do 372 | let gincs = getFieldStrings gflds [] "install-includes" 373 | incs = getFieldStrings flds [] "install-includes" 374 | dataPrefix = makeDataPrefix env glob sect 375 | incDir = dataPrefix "include" 376 | case gincs ++ incs of 377 | [] -> return () 378 | pats -> do 379 | let inc = head $ getFieldStrings flds ["."] "include-dirs" 380 | files <- matchFiles inc pats 381 | -- print (pats, files) 382 | message env 1 $ "Installing include files " ++ unwords files 383 | mkdir env incDir 384 | copyFiles env inc files incDir 385 | 386 | installCFiles :: Env -> Section -> Section -> IO () 387 | installCFiles env glob@(Section _ _ gflds) sect@(Section _ _ flds) = do 388 | let gcs = getFieldStrings gflds [] "c-sources" 389 | cs = getFieldStrings flds [] "c-sources" 390 | dataPrefix = makeDataPrefix env glob sect 391 | cDir = dataPrefix "cbits" 392 | case gcs ++ cs of 393 | [] -> return () 394 | files -> do 395 | message env 1 $ "Installing C files " ++ unwords files 396 | mkdir env cDir 397 | mapM_ (\ f -> cp env f cDir) files 398 | 399 | ----------------------------------------- 400 | 401 | cmdHelp :: Env -> [String] -> IO () 402 | cmdHelp _ _ = putStrLn "\ 403 | \Available commands:\n\ 404 | \ mcabal [FLAGS] build [PKG] build in current directory, or the package PKG\n\ 405 | \ mcabal [FLAGS] clean clean in the current directory\n\ 406 | \ mcabal [FLAGS] fetch PKG fetch files for package PKG\n\ 407 | \ mcabal [FLAGS] help show this message\n\ 408 | \ mcabal [FLAGS] install build and install in current directory\n\ 409 | \ mcabal [FLAGS] parse FILE just parse a Cabal file (for debugging)\n\ 410 | \ mcabal [FLAGS] update retrieve new set of consistent packages\n\ 411 | \\n\ 412 | \Flags:\n\ 413 | \ --version show version\n\ 414 | \ -fFLAGS set cabal flags\n\ 415 | \ -v be more verbose (can be repeated)\n\ 416 | \ -q be quiet\n\ 417 | \ -r do recursive installs for missing packages\n\ 418 | \ --ghc compile using ghc\n\ 419 | \ --mhs compile using mhs (default)\n\ 420 | \\n\ 421 | \Installs go to $CABALDIR if set, otherwise $HOME/.mcabal.\n\ 422 | \" 423 | 424 | ----------------------------------------- 425 | 426 | cmdClean :: Env -> [String] -> IO () 427 | cmdClean env _ = rmrf env (distDir env) 428 | 429 | ----------------------------------------- 430 | 431 | cmdParse :: Env -> [String] -> IO () 432 | cmdParse env [fn] = do 433 | rfile <- readFile fn 434 | let comp = backendNameVers (backend env) 435 | let cbl = parseCabal fn rfile 436 | info = FlagInfo { os = I.os, arch = I.arch, flags = eflags env, impl = comp } 437 | ncbl = normalize info cbl 438 | putStrLn "Unnormalized:" 439 | putStrLn $ showCabal cbl 440 | putStrLn "Normalized:" 441 | putStrLn $ showCabal ncbl 442 | cmdParse _ _ = error "cmdParse" 443 | -------------------------------------------------------------------------------- /src/MicroCabal/Normalize.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Normalize(normalize) where 2 | import Data.Function 3 | import Data.List 4 | import Data.Maybe 5 | import MicroCabal.Cabal 6 | --import Debug.Trace 7 | 8 | -- Do some normalization 9 | -- * computre conditionals and flatten 'if/else' 10 | -- * inline 'import' 11 | -- * combine identical fields 12 | -- * set library name 13 | 14 | normalize :: FlagInfo -> Cabal -> Cabal 15 | normalize info = libName . combine . inline . reduce info 16 | 17 | combine :: Cabal -> Cabal 18 | combine (Cabal ss) = Cabal $ map (\ (Section s n fs) -> Section s n (combineFields fs)) ss 19 | 20 | combineFields :: [Field] -> [Field] 21 | combineFields = map (foldl1 comb) . groupBy ((==) `on` fieldName) . sortBy (compare `on` fieldName) 22 | where fieldName (Field n _) = n 23 | fieldName _ = undefined -- Cannot happen, the Ifs are gone 24 | comb (Field n v1) (Field _ v2) = Field n (combineValue n v1 v2) 25 | comb _ _ = undefined 26 | 27 | combineValue :: FieldName -> Value -> Value -> Value 28 | combineValue _ (VItem x) (VItem y) | x == y = VItem x 29 | combineValue _ (VItems xs) (VItems ys) = VItems (xs ++ ys) 30 | combineValue _ (VBool x) (VBool y) = VBool (x && y) 31 | combineValue _ (VPkgs xs) (VPkgs ys) = VPkgs (xs ++ ys) 32 | combineValue _ (VXItem x) (VXItem y) = VXItem (x ++ "\n" ++ y) 33 | combineValue n v1 v2 = error $ "fields " ++ show n ++ " cannot be combined, values=" ++ show (v1, v2) 34 | 35 | inline :: Cabal -> Cabal 36 | inline (Cabal ss) = Cabal (map sect nss) 37 | where (css, nss) = partition (\ (Section s _ _) -> s == "common") ss 38 | coms = [ (n, fs) | Section _ n fs <- css ] 39 | sect (Section s n fs) = Section s n $ concatMap inl fs 40 | inl (Field "import" (VItem n)) = fromMaybe (error $ "No common " ++ show n) $ lookup n coms 41 | inl f = [f] 42 | 43 | libName :: Cabal -> Cabal 44 | libName (Cabal []) = undefined 45 | libName (Cabal (g@(Section _ _ gs):ss)) = Cabal $ g : map set ss 46 | where set (Section "library" "" fs) = Section "library" name fs 47 | set s = s 48 | name = getFieldString gs "name" 49 | 50 | reduce :: FlagInfo -> Cabal -> Cabal 51 | reduce info c = reduce' (addFlags c) c 52 | where addFlags (Cabal ss) = info{ flags = flags info ++ concatMap sect ss } 53 | sect (Section "flag" n fs) = [(n, dflt n fs)] 54 | sect _ = [] 55 | dflt n fs = head $ [ b | Field "default" (VBool b) <- fs ] ++ [error $ "no default for flag " ++ show n] 56 | 57 | reduce' :: FlagInfo -> Cabal -> Cabal 58 | reduce' info = mapField red 59 | where red (If c t e) --x | trace ("if " ++ show (c, cond info c)) False = undefined 60 | | cond info c = concatMap red t 61 | | otherwise = concatMap red e 62 | red f = [f] 63 | 64 | mapField :: (Field -> [Field]) -> Cabal -> Cabal 65 | mapField f (Cabal ss) = Cabal (map sect ss) 66 | where 67 | sect (Section s n fs) = Section s n (concatMap f fs) 68 | 69 | cond :: FlagInfo -> Cond -> Bool 70 | cond info = eval 71 | where eval (CBool b) = b 72 | eval (Cand a b) = eval a && eval b 73 | eval (Cor a b) = eval a || eval b 74 | eval (Cnot a) = not (eval a) 75 | eval (Cos s) = os info == s 76 | eval (Carch s) = arch info == s 77 | eval (Cflag n) = fromMaybe (error $ "Undefined flag " ++ show n) $ lookup n (flags info) 78 | eval (Cimpl s mv) = n == s && maybe True (inVersionRange v) mv where (n, v) = impl info 79 | 80 | inVersionRange :: Version -> VersionRange -> Bool 81 | inVersionRange v (VEQ v') = v == v' 82 | inVersionRange v (VGT v') = v > v' 83 | inVersionRange v (VLT v') = v < v' 84 | inVersionRange v (VLE v') = v <= v' 85 | inVersionRange v (VGE v') = v >= v' 86 | inVersionRange v (VOr vr1 vr2) = inVersionRange v vr1 || inVersionRange v vr2 87 | inVersionRange v (VAnd vr1 vr2) = inVersionRange v vr1 && inVersionRange v vr2 88 | inVersionRange v (VEQSet vs) = v `elem` vs 89 | inVersionRange _ vr = error $ "inVersionRange: not implemented " ++ show vr 90 | -------------------------------------------------------------------------------- /src/MicroCabal/Parse.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Parse( 2 | parseCabal, 3 | parseYAML, 4 | parseSnapshots, 5 | readVersion, 6 | ) where 7 | import Control.Applicative 8 | import Control.Monad 9 | import Data.Char 10 | import Data.List 11 | import Data.Maybe 12 | import Data.Version 13 | import Text.ParserComb 14 | import MicroCabal.Cabal 15 | import MicroCabal.YAML 16 | --import Debug.Trace 17 | 18 | parseCabal :: FilePath -> String -> Cabal 19 | parseCabal fn rfile = runP pCabalTop fn $ dropCabalComments rfile 20 | 21 | parseYAML :: FilePath -> String -> YAMLValue 22 | parseYAML fn rfile = runP pYAMLTop fn $ dropYAMLComments rfile 23 | 24 | parseSnapshots :: FilePath -> String -> [(String, String)] 25 | parseSnapshots fn rfile = runP pSnapshotsTop fn rfile 26 | 27 | runP :: P a -> FilePath -> String -> a 28 | runP prsr fn file = 29 | case runPrsr prsr (initLexState (preLex file)) of 30 | Left (LastFail n ts msgs) -> error $ "\n" ++ 31 | " found: " ++ (map show ts ++ ["EOF"]) !! 0 ++ "\n" ++ 32 | " expected: " ++ unwords (nub msgs) ++ "\n" ++ 33 | -- " n=" ++ show n ++ "\n" ++ 34 | " file: " ++ show fn ++ "\n" ++ 35 | " line: " ++ show (1 + length (filter (== '\n') (take (length file - n) file))) ++ "\n" ++ 36 | " at: " ++ show (take 100 (drop (length file - n) file)) 37 | Right (a:_) -> a 38 | Right [] -> undefined -- impossible 39 | 40 | -- Fixup of '\r' and '\t' 41 | preLex :: [Char] -> [Char] 42 | preLex = loop 0 43 | where 44 | loop :: Int -> [Char] -> [Char] 45 | loop _ [] = [] 46 | loop _ ('\n':cs) = '\n' : loop 0 cs 47 | loop _ ('\r':cs) = loop 0 cs 48 | loop n ('\t':cs) = replicate k ' ' ++ loop 0 cs 49 | where k = 8 - n `rem` 8 50 | loop n (c:cs) = c : loop (n+1) cs 51 | 52 | ------------------------------ 53 | 54 | type P a = Prsr LexState Char a 55 | 56 | data LexState = LS Int [Int] [Char] 57 | deriving (Show) 58 | 59 | initLexState :: [Char] -> LexState 60 | initLexState cs = LS 0 [] cs 61 | 62 | end :: Char 63 | end = '\EOT' 64 | fieldSep :: Char 65 | fieldSep = '\FS' 66 | 67 | instance TokenMachine LexState Char where 68 | -- tmNextToken ls | trace ("tmNextToken: " ++ show ls) False = undefined 69 | tmNextToken ls@(LS _ [] []) = (end, ls) -- ugly hack 70 | tmNextToken (LS i (_:ks) []) = (fieldSep, LS i ks []) 71 | tmNextToken (LS i [] (c:cs)) | c == '\n' = (c, LS 0 [] cs) 72 | | otherwise = (c, LS (i+1) [] cs) 73 | tmNextToken (LS i kks@(k:ks) (c:cs)) | c /= '\n' = (c, LS (i+1) kks cs) 74 | | otherwise = 75 | case skipEmpty cs of 76 | Just cs' -> tmNextToken (LS i kks cs') 77 | _ -> 78 | let lead 0 _ = ('\n', LS 0 kks cs) -- There are at least k leading spaces 79 | lead j (x:xs) | x == ' ' = lead (j-1) xs -- Count spaces 80 | lead _ _ = (fieldSep, LS 0 ks (c:cs)) -- Fewer than k spaces. Generate FS, pop, and try again. 81 | in lead (k+1) cs 82 | tmRawTokens (LS _ _ cs) = cs 83 | 84 | skipEmpty :: String -> Maybe String 85 | skipEmpty s = 86 | case dropWhile (== ' ') s of 87 | cs@('\n':_) -> Just cs 88 | _ -> Nothing 89 | 90 | pushColumn :: P () 91 | pushColumn = mapTokenState (\ (LS i ks cs) -> LS i (i:ks) cs) 92 | 93 | pushFieldSep :: P () 94 | pushFieldSep = mapTokenState (\ (LS i ks cs) -> LS i ks (fieldSep:cs)) 95 | 96 | lower :: String -> String 97 | lower = map toLower 98 | 99 | -- Change lines with first non-space being '--' into just a newline 100 | -- Remove '--MCABAL'. This is because cabal does not allow conditionals 101 | -- for the global section, and mhs needs that. 102 | dropCabalComments :: String -> String 103 | dropCabalComments = unlines . map cmt . lines 104 | where 105 | cmt ('-':'-':'M':'C':'A':'B':'A':'L':cs) = cmt cs 106 | cmt s | take 2 (dropWhile (== ' ') s) == "--" = "" 107 | | "--NOT_MHS" `isSuffixOf` s = "" 108 | | otherwise = s 109 | 110 | satisfySome :: String -> (Char -> Bool) -> P [Char] 111 | satisfySome msg p = (:) <$> satisfy msg p <*> satisfyMany p 112 | 113 | ---------------------------------------------------------------- 114 | 115 | pCabalTop :: P Cabal 116 | pCabalTop = pCabal <* pWhite <* pChar end 117 | 118 | pCabal :: P Cabal 119 | pCabal = Cabal <$> ((:) <$> (Section "global" "" <$> emany pField) <*> emany pSection) 120 | 121 | pColon :: P () 122 | pColon = pWhite <* pChar ':' 123 | 124 | pWhite :: P () 125 | pWhite = () <$ satisfyMany (\ c -> c == ' ' || c == '\n') 126 | 127 | pChar :: Char -> P () 128 | pChar c = () <$ satisfy (show c) (c ==) 129 | 130 | pFieldSep :: P () 131 | pFieldSep = pChar fieldSep 132 | 133 | pNewLine :: P () 134 | pNewLine = pChar '\n' 135 | 136 | pDot :: P () 137 | pDot = pChar '.' 138 | 139 | pSpaces :: P () 140 | pSpaces = () <$ satisfyMany (== ' ') 141 | 142 | pIdent :: P String 143 | pIdent = do 144 | c <- satisfy "ident" isAlpha_ 145 | cs <- satisfyMany isIdent 146 | pure (c:cs) 147 | 148 | pKeyWordNC :: String -> P String 149 | pKeyWordNC s = do 150 | pSpaces 151 | i <- pIdent 152 | guard (s == lower i) 153 | pure s 154 | 155 | isIdent :: Char -> Bool 156 | isIdent c = isAlphaNum c || c == '-' || c == '_' || c == '\'' || c == '.' 157 | 158 | isAlpha_ :: Char -> Bool 159 | isAlpha_ c = isAlpha c || c == '_' 160 | 161 | pNumber :: P Int 162 | pNumber = read <$> satisfySome "0..9" isDigit 163 | 164 | pParens :: P a -> P a 165 | pParens p = pStr "(" *> p <* pStr ")" 166 | 167 | pVersion :: P Version 168 | pVersion = pSpaces *> (makeVersion <$> esepBy1 pNumber pDot) 169 | 170 | pVersionRange :: P VersionRange 171 | pVersionRange = pVOr 172 | where 173 | pVOr = foldr1 VOr <$> esepBy1 pVAnd (pStr "&&") 174 | pVAnd = foldr1 VAnd <$> esepBy1 pVOp (pStr "||") 175 | pVOp = (pVOper <*> (pSpaces *> pVersion)) 176 | <|< pParens pVersionRange 177 | <|< (pStr "==" *> pVEq) 178 | <|< (pStr "^>=" *> pVGEHat) 179 | <|< (VGE (makeVersion [0]) <$ pStr "-any") 180 | <|< (VLT (makeVersion [0]) <$ pStr "-none") 181 | pVEq = (VEQSet <$> pVSet) <|< do 182 | v <- pVersion 183 | (VEQWild v <$ pStr ".*") <|< pure (VEQ v) 184 | pVSet = (pStr "{" *> pCommaList pVersion <* pStr "}") 185 | pVGEHat = (VGEHat <$> pVersion) <|< (VGEHatSet <$> pVSet) 186 | 187 | pVOper :: P (Version -> VersionRange) 188 | pVOper = pSpaces *> choice [ VGT <$ pStr ">", VLT <$ pStr "<", VGE <$ pStr ">=", VLE <$ pStr "<="] 189 | 190 | pStr :: String -> P () 191 | pStr s = pSpaces *> p s 192 | where p "" = pure () 193 | p (c:cs) = pChar c *> p cs 194 | 195 | pStrW :: String -> P () 196 | pStrW s = pWhite *> pStr s 197 | 198 | pItem :: P Item 199 | pItem = pWhite *> (pString <|< pWord) 200 | 201 | -- A string in quotation marks. 202 | pString :: P String 203 | pString = do 204 | pChar '"' 205 | let achar = satisfy "char" (\ c -> c /= '\n' && c /= end && c /= fieldSep) 206 | loop r = do 207 | c <- achar 208 | if c == '"' then 209 | return $ reverse r 210 | else if c /= '\\' then 211 | loop (c:r) 212 | else do 213 | e <- achar 214 | let e' = fromMaybe e $ lookup e [('n', '\n'), ('t', '\t')] -- could have more 215 | loop (e' : r) 216 | loop [] 217 | 218 | pWord :: P Item 219 | pWord = satisfySome "word" (\ c -> c `notElem` [' ', '\n', ',', end, fieldSep]) 220 | 221 | pComma :: P () 222 | pComma = pWhite *> pChar ',' 223 | 224 | pCommaList :: P a -> P [a] 225 | pCommaList p = (pStrW "," *> esepBy1 p pComma) 226 | <|< pCommaList' p 227 | 228 | pCommaList' :: P a -> P [a] 229 | pCommaList' p = esepBy p pComma <* eoptional (pStr ",") 230 | 231 | pSpaceList :: P a -> P [a] 232 | pSpaceList p = esepBy p' pWhite 233 | where 234 | -- sometimes (kan-extensions.cabal) there is a spurious comma, 235 | -- so allow that 236 | p' = p <* eoptional (pStr ",") 237 | 238 | pOptCommaList :: P a -> P [a] 239 | pOptCommaList p = 240 | (pStrW "," *> pCommaList' p) -- it starts with a ',', so it must be comma separated 241 | <|< do 242 | a <- p -- parse one item 243 | -- now check if we have a comma or not, and pick the parser for the rest 244 | as <- (pStrW "," *> pCommaList' p) <|< pSpaceList p 245 | return (a:as) 246 | <|< ([] <$ pWhite) 247 | 248 | pVComma :: P Value 249 | pVComma = VItems <$> pCommaList pItem 250 | 251 | pVSpace :: P Value 252 | pVSpace = VItems <$> pSpaceList pItem 253 | 254 | pVOptComma :: P Value 255 | pVOptComma = VItems <$> pOptCommaList pItem 256 | 257 | pVLibs :: P Value 258 | pVLibs = VPkgs <$> pCommaList pPkg 259 | 260 | pPkg :: P (Item, [Item], Maybe VersionRange) 261 | pPkg = (,,) <$> pNameW <*> (pSpaces *> pLibs) <*> optional pVersionRange 262 | where 263 | pLibs = do 264 | pColon 265 | ((:[]) <$> pNameW) <|< (pStr "{" *> pCommaList pName <* pStr "}") 266 | <|< 267 | pure [] 268 | pNameW = pWhite *> pIdent 269 | 270 | pField :: P Field 271 | pField = do 272 | pWhite 273 | pushColumn 274 | fn <- lower <$> pFieldName 275 | -- traceM ("pFieldName fn=" ++ show fn) 276 | if fn == "if" then do 277 | c <- pCond 278 | pNewLine 279 | t <- emany pField 280 | pFieldSep 281 | e <- do 282 | pWhite 283 | pushColumn 284 | _ <- pKeyWordNC "else" 285 | fs <- emany pField 286 | pFieldSep 287 | pure fs 288 | <|< 289 | pure [] 290 | pure $ If c t e 291 | else do 292 | pColon 293 | -- traceM $ "parser " ++ fn 294 | let p = getParser fn 295 | v <- p 296 | pFieldSep 297 | -- traceM ("pField v=" ++ show v) 298 | pure $ Field fn v 299 | 300 | pCond :: P Cond 301 | pCond = pCor 302 | where 303 | pCor = foldr1 Cor <$> esepBy1 pCand (pStr "||") 304 | pCand = foldr1 Cand <$> esepBy1 pCnot (pStr "&&") 305 | pCnot = (Cnot <$> (pStr "!" *> pCnot)) <|> pCOp 306 | pCOp = (CBool <$> pBool) 307 | <|< (pKeyWordNC "arch" *> pParens (Carch <$> pName)) 308 | <|< (pKeyWordNC "flag" *> pParens (Cflag <$> pName)) 309 | <|< (pKeyWordNC "impl" *> pParens (Cimpl <$> pName <*> optional pVersionRange)) 310 | <|< (pKeyWordNC "os" *> pParens (Cos <$> pName)) 311 | <|< pParens pCond 312 | 313 | pFreeText' :: P String 314 | pFreeText' = do 315 | txt <- satisfyMany (\ c -> c /= end && c /= fieldSep) 316 | let dot "." = "" -- Single '.' used to make an empty line 317 | dot s = s 318 | pure $ unlines . map (dot . dropWhile (== ' ')) . lines $ txt 319 | 320 | pFreeText :: P Value 321 | pFreeText = VItem <$> pFreeText' 322 | 323 | pFreeTextX :: P Value 324 | pFreeTextX = VXItem <$> pFreeText' 325 | 326 | pFieldName :: P FieldName 327 | pFieldName = pIdent 328 | 329 | pName :: P Name 330 | pName = pSpaces *> pIdent 331 | 332 | pFields :: P [Field] 333 | pFields = pSpaces *> pNewLine *> emany pField 334 | 335 | pBool :: P Bool 336 | pBool = (False <$ pKeyWordNC "false") <|< (True <$ pKeyWordNC "true") 337 | 338 | pSection :: P Section 339 | pSection = pWhite *> ( 340 | Section <$> pKeyWordNC "common" <*> pName <*> pFields 341 | <|< Section <$> pKeyWordNC "library" <*> libName <*> pFields 342 | <|< Section <$> pKeyWordNC "executable" <*> pName <*> pFields 343 | <|< Section <$> pKeyWordNC "source-repository" <*> pName <*> pFields 344 | <|< Section <$> pKeyWordNC "flag" <*> pName <*> pFields 345 | <|< Section <$> pKeyWordNC "test-suite" <*> pName <*> pFields 346 | <|< Section <$> pKeyWordNC "benchmark" <*> pName <*> pFields 347 | ) 348 | where libName = pName <|< pure "" 349 | 350 | getParser :: FieldName -> P Value 351 | getParser f = 352 | if "x-" `isPrefixOf` f then pFreeTextX else 353 | fromMaybe (error $ "Unknown field: " ++ f) $ lookup f parsers 354 | 355 | parsers :: [(FieldName, P Value)] 356 | parsers = 357 | [ "asm-options" # pVSpace 358 | , "asm-sources" # pVComma 359 | , "autogen-includes" # pVOptComma 360 | , "autogen-modules" # pVComma 361 | , "build-depends" # pVLibs 362 | , "build-tool-depends" # pVLibs -- ??? pVComma -- XXX 363 | , "build-tools" # pVComma -- XXX 364 | , "buildable" # (VBool <$> pBool) 365 | , "c-sources" # pVComma 366 | , "cc-options" # pVComma 367 | , "cmm-sources" # pVComma 368 | , "cmm-options" # pVComma 369 | , "cpp-options" # pVOptComma 370 | , "cxx-options" # pVComma 371 | , "default-extensions" # pVOptComma 372 | , "default-language" # (VItem <$> pItem) 373 | , "exposed-modules" # pVOptComma 374 | , "reexported-modules" # pVOptComma 375 | , "extensions" # pVOptComma 376 | , "extra-bundled-libraries" # pVComma 377 | , "extra-dynamic-library-flavours" # pVComma 378 | , "extra-framework-dirs" # pVComma 379 | , "extra-ghci-libraries" # pVComma 380 | , "extra-lib-dirs" # pVComma 381 | , "extra-lib-dirs-static" # pVComma 382 | , "extra-libraries" # pVComma 383 | , "frameworks" # pVOptComma 384 | , "ghc-options" # pVSpace 385 | , "ghc-prof-options" # pVSpace 386 | , "ghc-shared-options" # pVSpace 387 | , "ghcjs-options" # pVSpace 388 | , "ghcjs-prof-options" # pVSpace 389 | , "ghcjs-shared-options" # pVSpace 390 | , "hs-source-dirs" # pVOptComma 391 | , "import" # (VItem <$> pItem) 392 | , "include-dirs" # pVOptComma 393 | , "includes" # pVOptComma 394 | , "install-includes" # pVOptComma 395 | , "js-sources" # pVComma 396 | , "ld-options" # pVSpace 397 | , "mixins" # pFreeText -- XXX 398 | , "nhc98-options" # pVSpace 399 | , "other-extensions" # pVOptComma 400 | , "other-languages" # (VItem <$> pItem) 401 | , "other-modules" # pVOptComma 402 | , "pkg-config-depends" # pVComma 403 | , "virtual-modules" # pVComma 404 | --- library fields 405 | , "visibility" # (VItem <$> pItem) 406 | --- package fields 407 | , "author" # pFreeText 408 | , "bug-reports" # pFreeText 409 | , "build-type" # (VItem <$> pItem) 410 | , "cabal-version" # pFreeText -- (VRange <$> pVersionRange) 411 | , "category" # pFreeText 412 | , "copyright" # pFreeText 413 | , "data-dir" # pVSpace 414 | , "data-files" # pVOptComma 415 | , "description" # pFreeText 416 | , "extra-doc-files" # pVOptComma 417 | , "extra-source-files" # pVOptComma 418 | , "extra-tmp-files" # pVOptComma 419 | , "homepage" # pFreeText 420 | , "license" # pFreeText 421 | , "license-file" # pVOptComma 422 | , "license-files" # pVOptComma 423 | , "maintainer" # pFreeText 424 | , "name" # (VItem <$> pItem) 425 | , "package-url" # pFreeText 426 | , "stability" # pFreeText 427 | , "subdir" # pFreeText 428 | , "synopsis" # pFreeTextX 429 | , "tested-with" # pFreeText 430 | , "version" # (VVersion <$> pVersion) 431 | -- test suite fields 432 | , "main-is" # (VItem <$> pItem) 433 | , "test-module" # (VItem <$> pItem) 434 | , "type" # (VItem <$> pItem) 435 | -- source-repository fields 436 | , "location" # pFreeText 437 | -- flag fields 438 | , "manual" # (VBool <$> pBool) 439 | , "default" # (VBool <$> pBool) 440 | , "tag" # pFreeText 441 | ] 442 | where (#) = (,) 443 | -- XXX use local fixity 444 | 445 | 446 | ---------------------------------------------------------------------- 447 | 448 | -- XXX Wrong for strings 449 | dropYAMLComments :: String -> String 450 | dropYAMLComments [] = [] 451 | dropYAMLComments (c:cs) | c == '#' = dropYAMLComments (dropWhile (/= '\n') cs) 452 | | otherwise = c : dropYAMLComments cs 453 | 454 | pYAMLTop :: P YAMLValue 455 | pYAMLTop = pYAMLRecord <* pWhite <* pChar end 456 | 457 | pYAMLValue :: P YAMLValue 458 | pYAMLValue = 459 | (YBool <$> pBool) 460 | <|< (YInt <$> pNumber) 461 | -- <|< (YString <$> pString) 462 | <|< pYAMLArray 463 | <|< pYAMLRecord 464 | <|< (YString <$> pYAMLFree) 465 | 466 | pYAMLArray :: P YAMLValue 467 | pYAMLArray = do 468 | pWhite 469 | let 470 | pElem = pChar '-' *> pSpaces *> pYAMLValue 471 | pElemFS = pWhite *> pElem <* pFieldSep 472 | pElemsFS = esome pElemFS 473 | pElemNL = pElem <* pChar '\n' 474 | pElemsNL = pFieldSep *> pChar '\n' *> esome pElemNL <* pushFieldSep 475 | YArray <$> (pElemsNL <|< pElemsFS) 476 | 477 | pYAMLRecord :: P YAMLValue 478 | pYAMLRecord = YRecord <$> esome pYAMLField 479 | 480 | pYAMLFree :: P String 481 | pYAMLFree = do 482 | pSpaces 483 | d <- nextToken 484 | guard (d /= '-') 485 | txt <- satisfyMany (\ c -> c /= end && c /= fieldSep && c /= '\n') 486 | pure txt 487 | 488 | pYAMLField :: P (YAMLFieldName, YAMLValue) 489 | pYAMLField = do 490 | pWhite 491 | pushColumn 492 | n <- pFieldName 493 | pColon 494 | v <- pYAMLValue 495 | pFieldSep 496 | pure (n, v) 497 | 498 | ---------------------------------------------------------------------- 499 | 500 | type Snapshot = (String, String) 501 | 502 | pSnapshotsTop :: P [Snapshot] 503 | pSnapshotsTop = pSnapshots <* pWhite <* pChar end 504 | 505 | pSnapshots :: P [Snapshot] 506 | pSnapshots = pWhite *> pChar '{' *> (esepBy pSnapshot (pWhite *> pChar ',')) <* pWhite <* pChar '}' 507 | 508 | pSnapshot :: P Snapshot 509 | pSnapshot = (,) <$> (pWhite *> pString) <*> (pWhite *> pChar ':' *> pWhite *> pString) 510 | 511 | ---------------------------------------------------------------------- 512 | 513 | readVersion :: String -> Version 514 | readVersion = makeVersion . map read . words . map (\ c -> if c == '.' then ' ' else c) 515 | -------------------------------------------------------------------------------- /src/MicroCabal/Regex.hs: -------------------------------------------------------------------------------- 1 | -- Originally stolen from https://crypto.stanford.edu/~blynn/haskell/re.html 2 | 3 | -- Regular expression matching using Brzozowski's algorithm 4 | module MicroCabal.Regex(CharClass(..), Regex(..), eps, regexMatch) where 5 | import Data.List(sort, nub) 6 | 7 | data CharClass = Pos String | Neg String 8 | deriving (Eq, Ord, Show) 9 | 10 | elemCC :: Char -> CharClass -> Bool 11 | elemCC c (Pos cs) = c `elem` cs 12 | elemCC c (Neg cs) = c `notElem` cs 13 | 14 | data Regex 15 | = Lit CharClass 16 | | Seq Regex Regex 17 | | Star Regex 18 | | Or [Regex] 19 | | And [Regex] 20 | | Not Regex 21 | deriving (Eq, Ord, Show) 22 | 23 | regexMatch :: Regex -> String -> Bool 24 | regexMatch re "" = nullable re 25 | regexMatch re (c:s) = regexMatch (derive c re) s 26 | 27 | -- The regex `()`. The language containing only the empty string. 28 | eps :: Regex 29 | eps = Star noGood 30 | 31 | -- The regex `[]`. The empty language. 32 | noGood :: Regex 33 | noGood = Lit $ Pos [] 34 | 35 | -- The regex `.*`. The language containing everything. 36 | allGood :: Regex 37 | allGood = Star $ Lit $ Neg [] 38 | 39 | nullable :: Regex -> Bool 40 | nullable re = 41 | case re of 42 | Lit _ -> False 43 | Star _ -> True 44 | Seq r s -> nullable r && nullable s 45 | Or rs -> any nullable rs 46 | And rs -> all nullable rs 47 | Not r -> not $ nullable r 48 | 49 | derive :: Char -> Regex -> Regex 50 | derive c re = 51 | case re of 52 | Lit cc | elemCC c cc -> eps 53 | | otherwise -> noGood 54 | Star r -> derive c r `mkSeq` mkStar r 55 | r `Seq` s | nullable r -> mkOr [derive c r `mkSeq` s, derive c s] 56 | | otherwise -> derive c r `mkSeq` s 57 | And rs -> mkAnd $ map (derive c) rs 58 | Or rs -> mkOr $ map (derive c) rs 59 | Not r -> mkNot $ derive c r 60 | 61 | -- Smart constructors 62 | mkSeq :: Regex -> Regex -> Regex 63 | mkSeq r s 64 | | r == noGood || s == noGood = noGood 65 | | r == eps = s 66 | | s == eps = r 67 | | x `Seq` y <- r = x `mkSeq` (y `mkSeq` s) 68 | | otherwise = r `Seq` s 69 | 70 | mkOr :: [Regex] -> Regex 71 | mkOr xs 72 | | allGood `elem` zs = allGood 73 | | null zs = noGood 74 | | [z] <- zs = z 75 | | otherwise = Or zs 76 | where 77 | zs = nub $ sort $ filter (/= noGood) flat 78 | flat = concatMap deOr xs 79 | deOr (Or rs) = rs 80 | deOr r = [r] 81 | 82 | mkAnd :: [Regex] -> Regex 83 | mkAnd xs 84 | | noGood `elem` zs = noGood 85 | | null zs = allGood 86 | | [z] <- zs = z 87 | | otherwise = And zs 88 | where 89 | zs = nub $ sort $ filter (/= allGood) flat 90 | flat = concatMap deAnd xs 91 | deAnd (And rs) = rs 92 | deAnd r = [r] 93 | 94 | mkStar :: Regex -> Regex 95 | mkStar (Star s) = mkStar s 96 | mkStar r = Star r 97 | 98 | mkNot :: Regex -> Regex 99 | mkNot (Lit (Pos [])) = allGood 100 | mkNot (Not s) = s 101 | mkNot r = Not r 102 | -------------------------------------------------------------------------------- /src/MicroCabal/StackageList.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.StackageList( 2 | StackageList, 3 | StackagePackage(..), 4 | PackageName, FlagName, 5 | showPackage, 6 | readPackage, 7 | yamlToStackageList, 8 | yamlToGHCVersion, 9 | readVersionM, 10 | ) where 11 | import Data.Maybe 12 | import Data.Version 13 | import Text.Read 14 | import MicroCabal.YAML 15 | 16 | type StackageList = [StackagePackage] 17 | type PackageName = String 18 | type FlagName = String 19 | 20 | data StackagePackage = StackagePackage { 21 | stName :: PackageName, 22 | stVersion :: Version, 23 | stHidden :: Bool, 24 | stFlags :: [(FlagName, Bool)] 25 | } 26 | deriving (Show) 27 | 28 | showPackage :: StackagePackage -> String 29 | showPackage st = unwords $ stName st : showVersion (stVersion st) : show (stHidden st) : map flag (stFlags st) 30 | where flag (n,b) = n ++ "=" ++ show b 31 | 32 | readPackage :: String -> StackagePackage 33 | readPackage spkg = 34 | case words spkg of 35 | name : vers : hide : flgs -> 36 | StackagePackage { stName = name, stVersion = readVersion vers, stHidden = read hide, stFlags = map flag flgs } 37 | x -> error $ "readPackage" ++ show x 38 | where flag s = (n, read (drop 1 b)) where (n, b) = span (/= '=') s 39 | 40 | yamlToStackageList :: YAMLValue -> [StackagePackage] 41 | yamlToStackageList (YRecord flds) = 42 | let lookf s = fromMaybe (error $ "yamlToStackageList: no " ++ s) $ lookup s flds 43 | in case (lookf "flags", lookf "hidden", lookf "packages") of 44 | (YRecord flags, YRecord hidden, YArray packages) -> 45 | map (addFlags flags . addHidden hidden . decodePackage) packages 46 | _ -> error "Unrecognized Stackage package list format" 47 | yamlToStackageList _ = error "Unrecognized Stackage package list format" 48 | 49 | -- XXX Ugly, ugly hack because the YAML parser is brtoken. 50 | yamlToGHCVersion :: YAMLValue -> String 51 | yamlToGHCVersion (YRecord flds) = 52 | let bad n = error "yamlToGHCVersion: Unrecognized Stackage package list format " ++ show (n::Int) 53 | in case lookup "packages" flds of 54 | Just (YArray packages) -> 55 | case last packages of 56 | YRecord pflds -> 57 | case lookup "resolver" pflds of 58 | Just (YRecord rflds) -> 59 | case lookup "compiler" rflds of 60 | Just (YString s) -> s 61 | _ -> bad 1 62 | _ -> bad 2 63 | _ -> bad 3 64 | _ -> bad 4 65 | yamlToGHCVersion _ = error "Unrecognized Stackage package list format" 66 | 67 | addFlags :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage 68 | addFlags flags st = maybe st (\ f -> st{ stFlags = yflags f }) $ lookup (stName st) flags 69 | where yflags (YRecord r) = [(n, b) | (n, YBool b) <- r] 70 | yflags _ = error "addFlags" 71 | 72 | addHidden :: [(YAMLFieldName, YAMLValue)] -> StackagePackage -> StackagePackage 73 | addHidden hidden st = maybe st (\ f -> st{ stHidden = ybool f }) $ lookup (stName st) hidden 74 | where ybool (YBool b) = b 75 | ybool _ = error "addHidden" 76 | 77 | decodePackage :: YAMLValue -> StackagePackage 78 | decodePackage (YRecord (("hackage", YString fs):_)) = StackagePackage { stName = n, stVersion = v, stHidden = False, stFlags = [] } 79 | where 80 | s = takeWhile (/= '@') fs 81 | (n, v) = 82 | case span (/= '-') (reverse s) of 83 | (rv, rn) -> (reverse (drop 1 rn), readVersion (reverse rv)) 84 | decodePackage y = error $ "Bad package desc " ++ show y 85 | 86 | readVersion :: String -> Version 87 | readVersion s = fromMaybe (error $ "readVersion: bad version " ++ s) $ readVersionM s 88 | 89 | readVersionM :: String -> Maybe Version 90 | readVersionM s = makeVersion <$> (mapM readMaybe . words . map (\ c -> if c == '.' then ' ' else c) $ s) 91 | -------------------------------------------------------------------------------- /src/MicroCabal/Unix.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.Unix( 2 | cmd, tryCmd, cmdOut, tryCmdOut, 3 | mkdir, 4 | wget, URL(..), 5 | tarx, 6 | rmrf, 7 | cp, cpr, 8 | copyFiles, 9 | preserveCurrentDirectory, 10 | (), 11 | ) where 12 | import Control.Exception 13 | import Data.Maybe 14 | import System.Directory 15 | import System.Environment 16 | import System.IO 17 | import System.Process(callCommand) 18 | import MicroCabal.Env 19 | 20 | newtype URL = URL String 21 | 22 | cmd :: Env -> String -> IO () 23 | cmd env s = do 24 | message env 2 $ "cmd: " ++ s 25 | callCommand s 26 | 27 | tryCmd :: Env -> String -> IO Bool 28 | tryCmd env s = catch (cmd env s >> return True) f 29 | where f :: SomeException -> IO Bool 30 | f _ = return False 31 | 32 | cmdOut :: Env -> String -> IO String 33 | cmdOut env s = do 34 | (fn, h) <- tmpFile 35 | hClose h 36 | cmd env $ s ++ " >" ++ fn 37 | o <- readFile fn 38 | removeFile fn 39 | return o 40 | 41 | tryCmdOut :: Env -> String -> IO (Maybe String) 42 | tryCmdOut env s = do 43 | (fn, h) <- tmpFile 44 | hClose h 45 | b <- tryCmd env $ s ++ " >" ++ fn 46 | if b then do 47 | o <- readFile fn 48 | removeFile fn 49 | return (Just o) 50 | else 51 | return Nothing 52 | 53 | tmpFile :: IO (String, Handle) 54 | tmpFile = do 55 | mtmp <- lookupEnv "TMPDIR" 56 | let tmp = fromMaybe "/tmp" mtmp 57 | tmplt = "mcabal.txt" 58 | res <- try $ openTempFile tmp tmplt 59 | case res :: Either SomeException (String, Handle) of 60 | Right x -> return x 61 | Left _ -> openTempFile "." tmplt 62 | 63 | 64 | --------- 65 | 66 | -- Create a directory path, don't complain if it exists. 67 | mkdir :: Env -> String -> IO () 68 | mkdir env d = cmd env $ "mkdir -p " ++ d 69 | 70 | -- Get a document, store it in a file. 71 | wget :: Env -> URL -> FilePath -> IO () 72 | wget env (URL url) fn = cmd env $ "wget --quiet --output-document=" ++ fn ++ " " ++ url 73 | 74 | -- Extract a tar file 75 | tarx :: Env -> FilePath -> FilePath -> IO () 76 | tarx env dir file = cmd env $ "tar -C " ++ dir ++ " -x -f " ++ file 77 | 78 | -- Recursively remove 79 | rmrf :: Env -> FilePath -> IO () 80 | rmrf env fn = cmd env $ "rm -rf " ++ fn 81 | 82 | -- Copy a file to a directory 83 | cp :: Env -> FilePath -> FilePath -> IO () 84 | cp env s d = do 85 | cmd env $ "cp " ++ s ++ " " ++ d 86 | 87 | -- Copy a file to a directory, delete first 88 | cpr :: Env -> FilePath -> FilePath -> IO () 89 | cpr env s d = do 90 | cmd env $ "rm -f " ++ d 91 | cp env s d 92 | 93 | copyFiles :: Env -> FilePath -> [FilePath] -> FilePath -> IO () 94 | copyFiles env src fns tgt = do 95 | cmd env $ "cd " ++ src ++ "; tar cf - " ++ unwords fns ++ " | (cd " ++ tgt ++ "; tar xf - )" 96 | 97 | preserveCurrentDirectory :: IO a -> IO a 98 | preserveCurrentDirectory io = do 99 | cwd <- getCurrentDirectory 100 | a <- io 101 | setCurrentDirectory cwd 102 | return a 103 | 104 | ----- 105 | 106 | () :: FilePath -> FilePath -> FilePath 107 | x y = x ++ "/" ++ y 108 | -------------------------------------------------------------------------------- /src/MicroCabal/YAML.hs: -------------------------------------------------------------------------------- 1 | module MicroCabal.YAML( 2 | YAMLValue(..), 3 | YAMLFieldName, 4 | showYAML, 5 | ) where 6 | type YAMLFieldName = String 7 | 8 | data YAMLValue 9 | = YString String 10 | | YBool Bool 11 | | YInt Int 12 | | YRecord [(YAMLFieldName, YAMLValue)] 13 | | YArray [YAMLValue] 14 | deriving (Show) 15 | 16 | showYAML :: YAMLValue -> String 17 | showYAML = show 18 | -------------------------------------------------------------------------------- /src/Text/ParserComb.hs: -------------------------------------------------------------------------------- 1 | -- Copyright 2023 Lennart Augustsson 2 | -- See LICENSE file for full license. 3 | {-# OPTIONS_GHC -Wno-type-defaults #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | module Text.ParserComb( 6 | Prsr, runPrsr, 7 | satisfy, satisfyM, 8 | satisfyMany, 9 | choice, 10 | many, emany, optional, eoptional, 11 | some, esome, 12 | esepBy, sepBy1, esepBy1, 13 | esepEndBy, esepEndBy1, 14 | (), (<|<), 15 | --notFollowedBy, 16 | --lookAhead, 17 | nextToken, 18 | LastFail(..), 19 | TokenMachine(..), 20 | mapTokenState, 21 | ) where 22 | import Control.Applicative 23 | import Control.Monad 24 | 25 | data LastFail t 26 | = LastFail Int [t] [String] 27 | deriving (Show) 28 | 29 | maxInt :: Int 30 | maxInt = 1000000000 31 | 32 | noFail :: LastFail t 33 | noFail = LastFail maxInt [] [] 34 | 35 | longest :: LastFail t -> LastFail t -> LastFail t 36 | longest lf1@(LastFail l1 t1 x1) lf2@(LastFail l2 _ x2) = 37 | if l1 < l2 then 38 | lf1 39 | else if l2 < l1 then 40 | lf2 41 | else 42 | LastFail l1 t1 (x1 ++ x2) 43 | 44 | longests :: [LastFail t] -> LastFail t 45 | longests xs = foldl1 longest xs 46 | 47 | class TokenMachine tm t | tm -> t where 48 | tmNextToken :: tm -> (t, tm) 49 | tmRawTokens :: tm -> [t] 50 | 51 | tmLeft :: TokenMachine tm t => tm -> Int 52 | tmLeft = length . tmRawTokens 53 | 54 | firstToken :: TokenMachine tm t => tm -> [t] 55 | firstToken tm = 56 | case tmNextToken tm of 57 | (t, _) -> [t] 58 | 59 | data Res tm t a = Many [(a, tm)] (LastFail t) 60 | --deriving (Show) 61 | 62 | data Prsr tm t a = P (tm -> Res tm t a) 63 | --instance Show (Prsr s t a) where show _ = "<>" 64 | 65 | runP :: Prsr tm t a -> (tm -> Res tm t a) 66 | runP (P p) = p 67 | 68 | mapTokenState :: (tm -> tm) -> Prsr tm t () 69 | mapTokenState f = P (\ tm -> Many [((), f tm)] noFail) 70 | 71 | instance Functor (Prsr tm t) where 72 | fmap f p = P $ \ t -> 73 | case runP p t of 74 | Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf 75 | 76 | instance Applicative (Prsr tm t) where 77 | pure a = P $ \ t -> Many [(a, t)] noFail 78 | (<*>) = ap 79 | (*>) p k = p >>= \ _ -> k 80 | 81 | instance Monad (Prsr tm t) where 82 | (>>=) p k = P $ \ t -> 83 | case runP p t of 84 | Many aus plf -> 85 | let ms = map (\ (a, u) -> runP (k a) u) aus 86 | lfs = map (\ (Many _ lf) -> lf) ms 87 | rrs = [ r | Many rs _ <- ms, r <- rs ] 88 | in Many rrs (longests (plf : lfs)) 89 | return = pure 90 | 91 | instance TokenMachine tm t => MonadFail (Prsr tm t) where 92 | fail m = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) [m]) 93 | 94 | instance TokenMachine tm t => Alternative (Prsr tm t) where 95 | empty = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) ["empty"]) 96 | 97 | (<|>) p q = P $ \ t -> 98 | case runP p t of 99 | Many a lfa -> 100 | case runP q t of 101 | Many b lfb -> Many (a ++ b) (longest lfa lfb) 102 | 103 | -- Left biased choice 104 | infixl 3 <|< 105 | (<|<) :: Prsr tm t a -> Prsr tm t a -> Prsr tm t a 106 | (<|<) p q = P $ \ t -> 107 | case runP p t of 108 | Many [] lfa -> 109 | case runP q t of 110 | Many b lfb -> Many b (longest lfa lfb) 111 | r -> r 112 | 113 | satisfy :: TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t 114 | satisfy msg f = P $ \ acs -> 115 | case tmNextToken acs of 116 | r@(c, _) | f c -> Many [r] noFail 117 | _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg]) 118 | 119 | satisfyM :: TokenMachine tm t => String -> (t -> Maybe a) -> Prsr tm t a 120 | satisfyM msg f = P $ \ acs -> 121 | case tmNextToken acs of 122 | (c, cs) -> 123 | case f c of 124 | Just a -> Many [(a, cs)] noFail 125 | Nothing -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg]) 126 | 127 | satisfyMany :: TokenMachine tm t => (t -> Bool) -> Prsr tm t [t] 128 | satisfyMany f = P $ loop [] 129 | where loop res acs = 130 | case tmNextToken acs of 131 | (c, cs) | f c -> loop (c:res) cs 132 | | otherwise -> Many [(reverse res, acs)] noFail 133 | 134 | infixl 9 135 | () :: Prsr tm t a -> String -> Prsr tm t a 136 | () p e = P $ \ t -> 137 | -- trace (" " ++ show e) $ 138 | case runP p t of 139 | Many rs (LastFail l ts _) -> Many rs (LastFail l ts [e]) 140 | 141 | {- 142 | lookAhead :: forall tm t a . TokenMachine tm t => Prsr tm t a -> Prsr tm t () 143 | lookAhead p = P $ \ t -> 144 | case runP p t of 145 | Many [] (LastFail l ts xs) -> Many [] (LastFail l (take 1 ts) xs) 146 | _ -> Many [((), t)] noFail 147 | -} 148 | 149 | nextToken :: TokenMachine tm t => Prsr tm t t 150 | nextToken = P $ \ cs -> 151 | case tmNextToken cs of 152 | (c, _) -> Many [(c, cs)] noFail 153 | 154 | {- 155 | eof :: forall tm t . TokenMachine tm t => Prsr tm t () 156 | eof = P $ \ t@(cs, _) -> 157 | case tmNextToken cs of 158 | Nothing -> Many [((), t)] noFail 159 | Just _ -> Many [] (LastFail (tmLeft cs) (firstToken cs) ["eof"]) 160 | -} 161 | 162 | {- 163 | notFollowedBy :: forall t a . Prsr t a -> Prsr t () 164 | notFollowedBy p = P $ \ t@(ts,_) -> 165 | case runP p t of 166 | Many [] _ -> Many [((), t)] noFail 167 | _ -> Many [] (LastFail (length ts) (take 1 ts) ["!"]) 168 | -} 169 | 170 | runPrsr :: --X(Show a, Show s) => 171 | Prsr tm t a -> tm -> Either (LastFail t) [a] 172 | runPrsr (P p) f = 173 | case p f of 174 | Many [] lf -> Left lf 175 | Many xs _ -> Right [a | (a, _) <- xs ] 176 | 177 | ------------------------------- 178 | 179 | emany :: Prsr tm t a -> Prsr tm t [a] 180 | emany p = esome p <|< pure [] 181 | 182 | esome :: Prsr tm t a -> Prsr tm t [a] 183 | esome p = (:) <$> p <*> emany p 184 | 185 | eoptional :: Prsr tm t a -> Prsr tm t (Maybe a) 186 | eoptional p = (Just <$> p) <|< pure Nothing 187 | 188 | choice :: TokenMachine tm t => [Prsr tm t a] -> Prsr tm t a 189 | choice [] = empty 190 | choice ps = foldr1 (<|>) ps 191 | 192 | sepBy1 :: TokenMachine tm t => Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] 193 | sepBy1 p sep = (:) <$> p <*> many (sep *> p) 194 | 195 | esepBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] 196 | esepBy1 p sep = (:) <$> p <*> emany (sep *> p) 197 | 198 | esepBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] 199 | esepBy p sep = esepBy1 p sep <|< pure [] 200 | 201 | esepEndBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] 202 | esepEndBy p sep = esepEndBy1 p sep <|< pure [] 203 | 204 | esepEndBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a] 205 | esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure []) 206 | --------------------------------------------------------------------------------