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