ref: 68e8aa4275c2005d988d75f5c8ea89558d730db7
parent: f0cf670c61186245cc88ecbb3c7669880a48f8f0
author: Lennart Augustsson <augustss@Lennarts-Mini.augustsson.net>
date: Thu Nov 14 05:27:53 EST 2024
Update how -L works
--- a/ghc/Compat.hs
+++ b/ghc/Compat.hs
@@ -5,6 +5,7 @@
-- Functions for GHC that are defined in the UHS libs.
module Compat(module Compat, Type) where
import Data.Maybe
+import Data.List
import Data.Text(Text, append, pack)
import Control.Exception
import GHC.Types
@@ -15,6 +16,12 @@
takeWhileEnd :: forall a . (a -> Bool) -> [a] -> [a]
takeWhileEnd p = reverse . takeWhile p . reverse
+
+stripSuffix :: forall a . Eq a => [a] -> [a] -> Maybe [a]
+stripSuffix s t =
+ case stripPrefix (reverse s) (reverse t) of
+ Nothing -> Nothing
+ Just x -> Just (reverse x)
------- IO --------
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -11,6 +11,7 @@
packageDir, packageSuffix, packageTxtSuffix,
mhsVersion,
getMhsDir,
+ openFilePath,
) where
import Prelude(); import MHSPrelude
import Data.Char
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -47,6 +47,8 @@
(flags, mdls, rargs) = decodeArgs dflags [] args
pkgPaths | dir == dataDir && dir /= "." = [dropTrailing 3 dataDir] -- This is a bit ugly
| otherwise = [] -- No package search path
+ when (verbosityGT flags 1) $
+ putStrLn $ "flags = " ++ show flags
case listPkg flags of
Just p -> mainListPkg flags p
Nothing ->
@@ -55,8 +57,6 @@
Nothing ->
if installPkg flags then mainInstallPackage flags mdls else
withArgs rargs $ do
- when (verbosityGT flags 1) $
- putStrLn $ "flags = " ++ show flags
case mdls of
[] -> mainInteractive flags
[s] -> mainCompile flags (mkIdentSLoc (SLoc "command-line" 0 0) s)
@@ -63,7 +63,7 @@
_ -> error usage
usage :: String
-usage = "Usage: mhs [--version] [--numeric-version] [-v] [-q] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-IPATH] [-T] [-z] [-iPATH] [-oFILE] [-a[PATH]] [-LPATH] [-PPKG] [-Q PKG [DIR]] [-tTARGET] [ModuleName...]"
+usage = "Usage: mhs [--version] [--numeric-version] [-v] [-q] [-l] [-r] [-C[R|W]] [-XCPP] [-DDEF] [-IPATH] [-T] [-z] [-iPATH] [-oFILE] [-a[PATH]] [-L[PATH|PKG]] [-PPKG] [-Q PKG [DIR]] [-tTARGET] [MODULENAME..|FILE]"
-- Drop trailing '/foo'
dropTrailing :: Int -> FilePath -> FilePath
@@ -180,7 +180,21 @@
where readVersion = map readInt . words . map (\ c -> if c == '.' then ' ' else c)
mainListPkg :: Flags -> FilePath -> IO ()
-mainListPkg _flags pkgfn = do
+mainListPkg flags "" = mainListPackages flags
+mainListPkg flags pkg = do
+ ok <- doesFileExist pkg
+ if ok then
+ mainListPkg' flags pkg
+ else do
+ mres <- openFilePath (pkgPath flags) (packageDir ++ "/" ++ pkg ++ packageSuffix)
+ case mres of
+ Nothing -> error $ "Cannot find " ++ pkg
+ Just (pfn, hdl) -> do
+ hClose hdl
+ mainListPkg' flags pfn
+
+mainListPkg' :: Flags -> FilePath -> IO ()
+mainListPkg' _flags pkgfn = do
pkg <- readSerialized pkgfn
putStrLn $ "name: " ++ showIdent (pkgName pkg)
putStrLn $ "version: " ++ showVersion (pkgVersion pkg)
@@ -294,6 +308,18 @@
[] -> error $ "pkgPath is empty"
first:_ -> mainInstallPackage flags [pkgfn, first]
mainInstallPackage _ _ = error usage
+
+mainListPackages :: Flags -> IO ()
+mainListPackages flags = mapM_ list (pkgPath flags)
+ where list dir = do
+ let pdir = dir ++ "/" ++ packageDir
+ ok <- doesDirectoryExist pdir
+ when ok $ do
+ files <- getDirectoryContents pdir
+ let pkgs = [ b | f <- files, Just b <- [stripSuffix ".pkg" f] ]
+ putStrLn $ pdir ++ ":"
+ mapM_ (\ p -> putStrLn $ " " ++ p) pkgs
+
-- Convert something like
-- .../.mcabal/mhs-0.10.3.0/packages/base-0.10.3.0.pkg