exherbo-cabal 0.1.0.3 → 0.1.0.4
raw patch · 3 files changed
+115/−30 lines, 3 filesdep +http-types
Dependencies added: http-types
Files
- exherbo-cabal.cabal +5/−2
- src/ExRender.hs +49/−10
- src/Main.hs +61/−18
exherbo-cabal.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.3+version: 0.1.0.4 -- A short (one-line) description of the package. synopsis: Exheres generator for cabal packages@@ -51,6 +51,7 @@ location: https://github.com/ony/exherbo-cabal executable exherbo-cabal+ ghc-options: -O3 -Wall -fwarn-tabs -fwarn-monomorphism-restriction -- .hs or .lhs file containing the Main module. main-is: Main.hs @@ -60,10 +61,11 @@ -- LANGUAGE extensions used by modules in this package. other-extensions: FlexibleInstances,+ LambdaCase, OverloadedStrings, UnicodeSyntax, ViewPatterns- + -- Other library packages from which modules are imported. build-depends: Cabal >=1.20 && <1.23,@@ -72,6 +74,7 @@ containers, haddock-library >=1.0 && <1.3, http-client >=0.4 && <0.5,+ http-types <1, pcre-light <0.5, pretty >=1.1 && <1.2
src/ExRender.hs view
@@ -1,7 +1,7 @@ -- Copyright © 2015 Mykola Orliuk <virkony@gmail.com> -- Distributed under the terms of the GNU General Public License v2 -{-# LANGUAGE UnicodeSyntax, ViewPatterns #-}+{-# LANGUAGE UnicodeSyntax, ViewPatterns, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} @@ -28,16 +28,22 @@ exWrapWidth ∷ Int exWrapWidth = 80 +-- TODO: make GHC version configurable exGHCVersion ∷ Version-exGHCVersion = Version [7, 10, 1] [] -- TODO: solve this hard-coded GHC version assumption+exGHCVersion = case buildCompilerId of+ (CompilerId GHC ver) → ver+ x → error $ "Unsupported compiler " ++ show x exKnownLicenses ∷ [String] exKnownLicenses = ["CC0"] +-- | Double-quoted string for bash dquoted ∷ String → String dquoted [] = [] dquoted ('\\':xs) = "\\\\" ++ dquoted xs dquoted ('"':xs) = "\\\"" ++ dquoted xs+dquoted ('`':xs) = "\\`" ++ dquoted xs+dquoted ('$':xs) = "\\$" ++ dquoted xs dquoted (x:xs) = x : dquoted xs softWidth ∷ Int → [String] → [[String]]@@ -95,6 +101,7 @@ DocAName s → exDispQ s DocProperty s → exDispQ s DocExamples _ → empty -- XXX: examples are filtered out+ _ -> error $ "Unsupported haddock node" instance ExRender LowerBound where exDisp (LowerBound v InclusiveBound) = ">=" <> disp v@@ -105,17 +112,45 @@ exDisp (UpperBound v ExclusiveBound) = "<" <> disp v exDisp x = error $ "Unsupported UpperBound: " ++ show x +-- | Render some of VersionInterval's that can be represented with a single+-- condition and thus suitable for using in disjunction list+maybeExVersion ∷ VersionInterval → Maybe Doc+maybeExVersion = \case+ -- >=x && <=x+ (LowerBound a InclusiveBound, UpperBound b InclusiveBound)+ | a == b → Just $ char '=' <> disp a++ -- <x, <=x+ (LowerBound (Version [0] []) InclusiveBound, ub) → Just $ exDisp ub++ -- >=x, >x+ (lb, NoUpperBound) → Just $ exDisp lb++ (LowerBound (Version [] _) _, _) → Nothing+ (_, UpperBound (Version [] _) _) → Nothing+ -- >=x.y && <x.y'+ (LowerBound v@(Version a []) InclusiveBound, UpperBound (Version b []) ExclusiveBound)+ | init a == init b && succ (last a) == last b →+ Just $ char '=' <> disp v <> char '*'++ (LowerBound (Version [_] _) _, _) → Nothing+ -- >=x.y.z && <x.y'+ (LowerBound v@(Version a []) InclusiveBound, UpperBound (Version b []) ExclusiveBound)+ | init a' == init b && succ (last a') == last b →+ Just $ char '~' <> disp v+ where a' = init a++ _ → Nothing+ instance ExRender VersionInterval where- exDisp (LowerBound v InclusiveBound,- UpperBound v' InclusiveBound) | v == v' = brackets ("=" <> disp v) exDisp (LowerBound (Version [0] []) InclusiveBound, NoUpperBound) = empty- exDisp (LowerBound (Version [0] []) InclusiveBound, ub) = brackets (exDisp ub)- exDisp (lb, NoUpperBound) = brackets (exDisp lb)- exDisp (lb, ub) = brackets (exDisp lb <> char '&' <> exDisp ub)+ exDisp (maybeExVersion → Just exVi) = exVi+ exDisp (lb, ub) = exDisp lb <> char '&' <> exDisp ub instance ExRender VersionRange where exDisp vr = case asVersionIntervals vr of- [vi] → exDisp vi+ [vi] → nbrackets $ exDisp vi+ (mapM maybeExVersion → Just exVis) → nbrackets . hcat $ punctuate (char '|') exVis _ → error $ "Unsupported version range: " ++ display vr instance ExRender Dependency where@@ -129,9 +164,13 @@ exDisp (LGPL (Just v)) = "LGPL-" <> disp v exDisp (Apache Nothing) = "Unspecified-Apache" exDisp (Apache (Just v)) = "Apache-" <> disp v+ exDisp (MPL v) = "MPL-" <> disp v+ exDisp BSD2 = "BSD-2" exDisp BSD3 = "BSD-3" exDisp BSD4 = "BSD-4"+ exDisp ISC = "ISC" exDisp MIT = "MIT"+ exDisp PublicDomain = "public-domain" exDisp (UnknownLicense "BSD2") = "BSD-2" exDisp (UnknownLicense "MPL-2") = "MPL-2.0" exDisp (UnknownLicense x) | x `elem` exKnownLicenses = text x@@ -237,8 +276,8 @@ build t = condTreeConstraints t ++ concatMap buildOptional (condTreeComponents t) buildOptional (eval → True, t, _) = build t- buildOptional (eval → False, _, Just t) = build t- buildOptional (eval → False, _, Nothing) = []+ buildOptional (_, _, Just t) = build t+ buildOptional (_, _, Nothing) = [] collectLibDeps, collectBinDeps, collectTestDeps ∷ GenericPackageDescription → [Dependency] collectLibDeps = collectDeps (maybeToList . condLibrary)
src/Main.hs view
@@ -5,8 +5,8 @@ module Main where -import Control.Applicative import Control.Monad+import Control.Concurrent (threadDelay) import Control.Exception import Data.Maybe import Data.ByteString.Lazy.Char8 (unpack)@@ -22,6 +22,7 @@ import Distribution.PackageDescription.Parse import Distribution.Verbosity import Network.HTTP.Client+import Network.HTTP.Types import qualified Text.Regex.PCRE.Light.Char8 as R @@ -30,7 +31,12 @@ -- |Fetch content by provided URI simpleFetch ∷ String → IO String simpleFetch url = do- let settings = defaultManagerSettings+ let settings = defaultManagerSettings { managerRetryableException = isTemporary+ , managerResponseTimeout = Just 120000000+ , managerWrapIOException = (threadDelay 1 >>)+ }+ isTemporary (fromException → Just (StatusCodeException e _ _)) = statusCode e `elem` [503]+ isTemporary _ = False req ← parseUrl url withManager settings $ liftM (unpack . responseBody) . httpLbs req @@ -53,13 +59,24 @@ hackageBaseUri = "http://hackage.haskell.org/package/" fixLicense ∷ GenericPackageDescription → IO GenericPackageDescription-fixLicense descr | license pkgDescr == OtherLicense = adjustLicense+fixLicense descr | isNothing maybeLicensePath = return descr+ | license pkgDescr == OtherLicense = catch adjustLicense handler | otherwise = return descr where pkgDescr = packageDescription descr packageUri = hackageBaseUri ++ display (package pkgDescr)++ handler ∷ SomeException → IO GenericPackageDescription+ handler e = do+ hPutStrLn stderr $ "# No license fix for " ++ display (package pkgDescr) ++ ": " ++ show e+ return descr++ -- TODO: proper handling of multiple licenses+ maybeLicensePath = case licenseFiles pkgDescr of+ [x] → Just x+ _ → Nothing adjustLicense = do- let licensePath = head $ licenseFiles pkgDescr -- TODO: proper handling of multiple licenses+ let licensePath = fromJust $ maybeLicensePath licenseContent ← simpleFetch (packageUri ++ "/src/" ++ licensePath) license' ← guessLicense licenseContent case license' of@@ -84,17 +101,43 @@ main ∷ IO () main = do args ← getArgs- sources ← case args of- [] → liftM lines getContents- _ → return args- forM_ sources $ \source → do- descr ← case source of- ('.':_) → readPackageDescription verbose source >>= fixLicense- ('/':_) → readPackageDescription verbose source >>= fixLicense- (simpleParse → Just pkgId) -> fetchPackageDescription pkgId- _ -> error $ "Specified source " ++ show source- ++ " neither starts with '.' or '/' (local file)"- ++ " nor a valid packageIdentifier (to fetch from hackage)"- let handler ∷ SomeException → IO ()- handler e = hPutStrLn stderr $ "# Failed fetch/generate for " ++ show source ++ ": " ++ show e- catch (evaluate (exRender descr) >>= putStrLn) handler+ case args of+ "-h":_ → putStr helpString+ "--help":_ → putStr helpString+ _ → do+ sources ← case args of+ [] → liftM lines getContents+ _ → return args+ forM_ sources $ \source → do+ hPutStrLn stderr $ "# Processing " ++ show source+ descr ← case source of+ ('.':_) → readPackageDescription verbose source >>= fixLicense+ ('/':_) → readPackageDescription verbose source >>= fixLicense+ (simpleParse → Just pkgId) -> fetchPackageDescription pkgId+ _ -> error $ "Specified source " ++ show source+ ++ " neither starts with '.' or '/' (local file)"+ ++ " nor a valid packageIdentifier (to fetch from hackage)"+ let handler ∷ SomeException → IO ()+ handler e = hPutStrLn stderr $ "# Failed fetch/generate for " ++ show source ++ ": " ++ show e+ catch (evaluate (exRender descr) >>= putStrLn) handler+++helpString :: String+helpString =+ "Generate package description from .cabal files in format of exheres-0 for\n" +++ "Exherbo Linux.\n" +++ "\n" +++ "See https://github.com/ony/exherbo-cabal\n" +++ "\n" +++ "Usage: exherbo-cabal [ -h | --help | <ref-to-package> ... ]\n"+++ " -h | --help Print this help and exit\n" +++ " <ref-to-package> either a package name (mtl) at Hackage with optional\n" +++ " version (mtl-2.2.1) or path to local cabal file (./exherbo-cabal.cabal)\n" +++ " If no <ref-to-package> provided in args read them from standart input\n" +++ "\n" +++ "Examples:\n" +++ " > exherbo-cabal mtl-2.2.1\n" +++ " > exherbo-cabal mtl transformers\n" +++ " > echo yesod-core | exherbo-cabal\n" +++ " > exherbo-cabal ./exherbo-cabal.cabal\n" +++ " > find /tmp/index -name \\*.cabal | exherbo-cabal\n"