exherbo-cabal 0.1.1.0 → 0.2.0.0

raw patch · 8 files changed

+436/−272 lines, 8 filesdep +ansi-wl-pprintdep +data-defaultdep +optparse-applicativedep ~exherbo-cabalPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-wl-pprint, data-default, optparse-applicative

Dependency ranges changed: exherbo-cabal

API changes (from Hackage documentation)

Files

• exherbo-cabal.cabal +12/−2
• src/ExRender.hs +52/−228
• src/ExRender/Base.hs +74/−0
• src/ExRender/Dependency.hs +115/−0
• src/ExRender/Haddock.hs +37/−0
• src/ExRender/License.hs +37/−0
• src/Main.hs +94/−41
• src/doctests.hs +15/−1

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.1.0+version:             0.2.0.0  -- A short (one-line) description of the package. synopsis:            Exheres generator for cabal packages@@ -54,10 +54,17 @@   Exposed-modules:     ExRender +  Other-modules:+    ExRender.Base+    ExRender.Dependency+    ExRender.Haddock+    ExRender.License+   build-depends:     Cabal >=1.20 && <1.23,     base >=4.7 && <4.9,     containers,+    data-default >=0.2 && <1,     haddock-library >=1.0 && <1.3,     pretty >=1.1 && <1.2 @@ -92,11 +99,14 @@   -- Other library packages from which modules are imported.   build-depends:     Cabal >=1.20 && <1.23,+    ansi-wl-pprint >=0.6 && <0.7,     base >=4.7 && <4.9,     bytestring >=0.10 && <0.11,-    exherbo-cabal >=0.1.1 && <0.2,+    data-default >=0.2 && <1,+    exherbo-cabal >=0.2 && <0.3,     http-client >=0.4 && <0.5,     http-types <1,+    optparse-applicative >=0.12 && <0.13,     pcre-light <0.5      -- Base language which the package is written in.

@@ -1,214 +1,65 @@ -- Copyright © 2015 Mykola Orliuk <virkony@gmail.com> -- Distributed under the terms of the GNU General Public License v2 +{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnicodeSyntax, ViewPatterns, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module ExRender (exDisp, exDispQ, exRender) where+module ExRender (ExCabalEnv(..), ExRenderPackage, exDisp, exDispQ, exRenderPkg) where  import Data.Maybe import Data.List import Data.Function+import Data.Default import qualified Data.Map as M-import Text.PrettyPrint  import Control.Arrow ((&&&))  import Distribution.Text import Distribution.Package import Distribution.Version-import Distribution.License import Distribution.Compiler import Distribution.System import Distribution.PackageDescription import Documentation.Haddock.Parser-import Documentation.Haddock.Types hiding (Version) -exWrapWidth ∷ Int-exWrapWidth = 80---- TODO: make GHC version configurable-exGHCVersion ∷ Version-exGHCVersion = case buildCompilerId of-                (CompilerId GHC ver) → ver-                x → error $ "Unsupported compiler " ++ show x--exKnownLicenses ∷ [String]-exKnownLicenses = ["CC0", "AGPL-3"]---- | 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]]-softWidth width = build 0 [] where-    build _ ys [] = [reverse ys]-    build 0 [] (w:ws) = build (length w) [w] ws-    build n ys (w:ws) | n' > width = reverse ys : build 0 [] (w:ws)-                      | otherwise = build n' (w : ys) ws-        where-            n' = length w + n--reflow ∷ Int → String → Doc-reflow width = vcat . map (text . unwords) . softWidth width . words---- |Wrap doc with spaces around-spaces ∷ Doc → Doc-spaces doc | isEmpty doc = empty-           | otherwise = space <> doc <> space---- |Wrap with brackets non-empty doc-nbrackets ∷ Doc → Doc-nbrackets doc | isEmpty doc = empty-              | otherwise = brackets doc--class ExRender a where-    -- |Renders 'a' into a 'Doc' representing some part of exheres-    exDisp :: a → Doc--class ExRenderQ a where-    -- |Renders 'a' into a 'Doc' to be placed within double-quotes inside of exheres-    exDispQ :: a → Doc--instance ExRenderQ String where-    -- TODO: exDispQ = sep . map text . words . dquoted-    exDispQ = text . dquoted--instance ExRender Identifier where exDisp (_, s, _) = text s-instance ExRenderQ Identifier where exDispQ = exDisp--instance ExRenderQ id => ExRenderQ (DocH mod id) where-    exDispQ x = case x of-        DocEmpty → empty-        DocAppend a b → exDispQ a <> exDispQ b-        DocString s → exDispQ s-        DocParagraph a → exDispQ a-        DocIdentifier s → exDispQ s-        DocModule s → exDispQ s-        DocWarning a → exDispQ a-        DocEmphasis a → exDispQ a-        DocMonospaced a → exDispQ a-        DocBold a → exDispQ a-        DocHyperlink (Hyperlink _ (Just s)) → exDispQ s-        DocHyperlink (Hyperlink s Nothing) → exDispQ s-        DocPic _ → empty -- XXX: no images in description-        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-    exDisp (LowerBound v ExclusiveBound) = ">" <> disp v--instance ExRender UpperBound where-    exDisp (UpperBound v InclusiveBound) = "<=" <> disp v-    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.------ >>> map maybeExVersion $ asVersionIntervals (fromJust $ simpleParse ">=1.0 || ==0.1.*" :: VersionRange)--- [Just =0.1*,Just >=1.0]-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---- | Transform VersionInterval in a sequence of disjunctions------ >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0" :: VersionRange)--- [[>=1.0]]--- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0 && <1.3" :: VersionRange)--- [[=1.0*,=1.1*,=1.2*]]--- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0 && <=1.3" :: VersionRange)--- [[=1.0*,=1.1*,=1.2*,=1.3]]--- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1 && <=1.3" :: VersionRange)--- [[=1,=1.0*,=1.1*,=1.2*,=1.3]]--- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1 && <=1.0.3" :: VersionRange)--- [[=1,=1.0,=1.0.0*,=1.0.1*,=1.0.2*,=1.0.3]]-exVersions ∷ VersionInterval → [Doc]-exVersions = \case-    (maybeExVersion → Just x) → [x]--    -- ... && <=x.b-    (lb, UpperBound v InclusiveBound) →-        exVersions (lb, UpperBound v ExclusiveBound) ++ [char '=' <> disp v]--    -- >=x.a && <x.b-    (LowerBound va@(Version a _) InclusiveBound, ub@(UpperBound (Version b _) ExclusiveBound))-        | init a == init b → do-            c ← [init a ++ [i] | i ← [last a .. last b - 1]]-            return $ char '=' <> disp (Version c []) <> char '*'-        | length a < length b →-            char '=' <> disp va : exVersions (LowerBound (Version (a ++ [0]) []) InclusiveBound, ub)-    _ → []--instance ExRender VersionInterval where-    exDisp (LowerBound (Version [0] []) InclusiveBound, NoUpperBound) = empty-    exDisp (maybeExVersion → Just exVi) = exVi-    exDisp (lb, ub) = exDisp lb <> char '&' <> exDisp ub+import ExRender.Base+import ExRender.Haddock ()+import ExRender.License ()+import ExRender.Dependency () -instance ExRender VersionRange where-    exDisp vr = case asVersionIntervals vr of-        [vi] → nbrackets $ exDisp vi-        (concatMap exVersions → exVis) | not $ null exVis → nbrackets . hcat $ punctuate (char '|') exVis-        _ → error $ "Unsupported version range: " ++ display vr+data ExCabalEnv = ExCabalEnv+    { exGHCVersion ∷ Version+    , exCopyright ∷ Doc+    , exBugsTo ∷ String+    }+    deriving (Show) -instance ExRender Dependency where-    exDisp (Dependency n vr) = "dev-haskell/" <> disp n <> exDisp vr+instance Default ExCabalEnv where+    def = ExCabalEnv+        { exGHCVersion = case buildCompilerId of+            (CompilerId GHC ver) → ver+            x → error $ "Unsupported compiler " ++ show x+        , exCopyright = vcat+            [ "# Copyright 2015 Mykola Orliuk <virkony@gmail.com>"+            , "# Distributed under the terms of the GNU General Public License v2"+            ]+        , exBugsTo = "virkony@gmail.com"+        } -instance ExRender License where-    exDisp (GPL Nothing) = "Unspecified-GPL"-    exDisp (GPL (Just v)) = "GPL-" <> disp v-    exDisp (AGPL (Just v)) = "AGPL-" <> disp v-    exDisp (LGPL Nothing) = "Unspecified-LGPL"-    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-    exDisp x = error $ "Unsupported license: " ++ display x+class ExRenderPackage a where+    type ExPackageEnv a+    exDispPkg ∷ ExPackageEnv a → a → Doc  instance ExRender GenericPackageDescription where-    exDisp descr = exheres where+    exDisp = exDispPkg def++instance ExRenderPackage GenericPackageDescription where+    type ExPackageEnv GenericPackageDescription = ExCabalEnv+    exDispPkg env descr = exheres where         nameSelf = pkgName . package $ packageDescription descr         ignoredPkgIds = map (fromJust . simpleParse) ["base", "ghc", "ghc-prim"] @@ -227,17 +78,17 @@         exLibDeps | null libDeps = empty                   | otherwise = exDepFn "haskell_lib_dependencies" libDeps             where-                libDeps = filter (not . ignoredDep) (collectLibDeps descr)+                libDeps = filter (not . ignoredDep) (collectLibDeps env descr)          exBinDeps | null binDeps = empty                   | otherwise = exDepFn "haskell_bin_dependencies" binDeps             where-                binDeps = filter (not . ignoredBinDep) (collectBinDeps descr)+                binDeps = filter (not . ignoredBinDep) (collectBinDeps env descr)          exTestDeps = case condTestSuites descr of             [] → empty             _ → exDepFn "haskell_test_dependencies" testDeps where-                testDeps = filter (not . ignoredTestDep) (collectTestDeps descr)+                testDeps = filter (not . ignoredTestDep) (collectTestDeps env descr)          exDependencies = vcat [             "DEPENDENCIES=\"",@@ -263,10 +114,9 @@                                  ]                 exParams = spaces $ exHasLib <+> exHasBin <+> exHasOptions -        exSlot = if hasLib then empty else exField "SLOT" "0"+        exSlot = if not hasBin && hasLib then empty else exField "SLOT" "0"         exheres = vcat [-            "# Copyright 2015 Mykola Orliuk <virkony@gmail.com>",-            "# Distributed under the terms of the GNU General Public License v2",+            exCopyright env,             "# Generated for " <> disp (package pkgDescr),             "",             exRequire,@@ -275,33 +125,33 @@             exFieldDoc "DESCRIPTION" (exDispQ . toRegular . parseString $ description pkgDescr),             exField "HOMEPAGE" (homepage pkgDescr),             "",-            exField "LICENCES" (exRender $ license pkgDescr),+            exField "LICENCES" (render . exDisp $ license pkgDescr),             exSlot,             exField "PLATFORMS" "~amd64",             "",             exDependencies,             "",-            exField "BUGS_TO" "virkony@gmail.com",+            exField "BUGS_TO" (exBugsTo env),             ""             ]  -- |Collect dependencies from all 'CondTree' nodes of -- 'GenericPackageDescription' using provided view-collectDeps ∷ (GenericPackageDescription → [CondTree ConfVar [Dependency] a])+collectDeps ∷ ExCabalEnv → (GenericPackageDescription → [CondTree ConfVar [Dependency] a])               → GenericPackageDescription → [Dependency]-collectDeps view descr = concatMap build (view descr) where+collectDeps env view descr = concatMap build (view descr) where     flags = M.fromList . map (flagName &&& id) $ genPackageFlags descr     eval (Var (Flag k)) = flagDefault . fromJust $ M.lookup k flags     eval (Var (OS Linux)) = True -- TODO: solve this hard-coded OS assumption     eval (Var (OS _)) = False     eval (Var (Arch X86_64)) = True -- TODO: support other platforms besides amd64     eval (Var (Arch _)) = False-    eval (Var (Impl GHC vr)) = exGHCVersion `withinRange` vr+    eval (Var (Impl GHC vr)) = exGHCVersion env `withinRange` vr     eval (Var (Impl _ _)) = False -- XXX: no support for non-GHC compilers     eval (Lit f) = f     eval (CNot e) = not (eval e)     eval (COr a b) = eval a || eval b-    eval (CAnd a b) = eval a || eval b+    eval (CAnd a b) = eval a && eval b     -- eval e = error $ "Unsupported expr " ++ show e      build t = condTreeConstraints t ++ concatMap buildOptional (condTreeComponents t)@@ -310,27 +160,14 @@     buildOptional (_, _, Just t) = build t     buildOptional (_, _, Nothing) = [] -collectLibDeps, collectBinDeps, collectTestDeps ∷ GenericPackageDescription → [Dependency]-collectLibDeps = collectDeps (maybeToList . condLibrary)-collectBinDeps = collectDeps (map snd . condExecutables)-collectTestDeps = collectDeps (map snd . condTestSuites)---- |Render 'a' to a final part of Exheres-exRender ∷ ExRender a ⇒ a → String-exRender = render . exDisp---- |Render a multi-line meta-field of Exheres if non-empty value-exFieldDoc ∷ String → Doc → Doc-exFieldDoc name value | isEmpty value = empty-                      | otherwise = vcat [text name <> "=\"", value, char '"']+collectLibDeps, collectBinDeps, collectTestDeps ∷ ExCabalEnv → GenericPackageDescription → [Dependency]+collectLibDeps env = collectDeps env (maybeToList . condLibrary)+collectBinDeps env = collectDeps env (map snd . condExecutables)+collectTestDeps env = collectDeps env (map snd . condTestSuites) --- |Render a single-line with potential wrap meta-field of Exheres if non-empty value-exField ∷ String → String → Doc-exField _ "" = empty-exField name x | length singleLine < exWrapWidth = text singleLine-               | otherwise = exFieldDoc name (reflow exWrapWidth (dquoted x))-    where-        singleLine = name ++ "=\"" ++ dquoted x ++ "\""+-- | Render 'a' to a final Exheres+exRenderPkg ∷ ExRenderPackage a ⇒ ExPackageEnv a → a → String+exRenderPkg env = render . exDispPkg env  -- |Sort dependencies according to Exherbo order sortDeps ∷ [Dependency] → [Dependency]@@ -347,16 +184,3 @@  -- TODO: drop test deps that already in build -- TODO: use renderStyle instead of manual wrapping---- $setup------ doctest examples:------ >>> exRender (fromJust $ simpleParse ">=1.0 && <1.3" :: VersionRange)--- "[>=1.0&<1.3]"--- >>> exRender (fromJust $ simpleParse ">=1.1 && <2" :: VersionRange)--- "[~1.1]"--- >>> exRender (fromJust $ simpleParse "==1.* || ==3.*" :: VersionRange)--- "[=1*|=3*]"--- >>> exRender (fromJust $ simpleParse "==1.1.* || ==1.0.* || ==0.11.*" :: VersionRange)--- "[=0.11*|=1.0*|=1.1*]"

@@ -0,0 +1,74 @@+-- Copyright © 2015 Mykola Orliuk <virkony@gmail.com>+-- Distributed under the terms of the GNU General Public License v2++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE FlexibleInstances #-}++module ExRender.Base+    ( module ExRender.Base+    , module Text.PrettyPrint+    ) where++import Text.PrettyPrint++-- | Wrap width soft limitt+exWrapWidth ∷ Int+exWrapWidth = 80++class ExRender a where+    -- | Renders 'a' into a 'Doc' representing some part of exheres+    exDisp ∷ a → Doc++class ExRenderQ a where+    -- | Renders 'a' into a 'Doc' to be placed within double-quotes inside of exheres+    exDispQ ∷ a → Doc++-- | 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++-- | Split String in lines according to soft limit+softWidth ∷ Int → [String] → [[String]]+softWidth width = build 0 [] where+    build _ ys [] = [reverse ys]+    build 0 [] (w:ws) = build (length w) [w] ws+    build n ys (w:ws) | n' > width = reverse ys : build 0 [] (w:ws)+                      | otherwise = build n' (w : ys) ws+        where+            n' = length w + n++-- | Build a Doc out of String respecting soft width limit+reflow ∷ Int → String → Doc+reflow width = vcat . map (text . unwords) . softWidth width . words++-- | Wrap doc with spaces around if non-empty+spaces ∷ Doc → Doc+spaces doc | isEmpty doc = empty+           | otherwise = space <> doc <> space++-- | Wrap with brackets non-empty doc+nbrackets ∷ Doc → Doc+nbrackets doc | isEmpty doc = empty+              | otherwise = brackets doc++-- | Render a multi-line meta-field of Exheres if non-empty value+exFieldDoc ∷ String → Doc → Doc+exFieldDoc name value | isEmpty value = empty+                      | otherwise = vcat [text name <> text "=\"", value, char '"']++-- |Render a single-line with potential wrap meta-field of Exheres if non-empty value+exField ∷ String → String → Doc+exField _ "" = empty+exField name x | length singleLine < exWrapWidth = text singleLine+               | otherwise = exFieldDoc name (reflow exWrapWidth (dquoted x))+    where+        singleLine = name ++ "=\"" ++ dquoted x ++ "\""++instance ExRenderQ String where+    -- TODO: exDispQ = sep . map text . words . dquoted+    exDispQ = text . dquoted

@@ -0,0 +1,115 @@+-- Copyright © 2015 Mykola Orliuk <virkony@gmail.com>+-- Distributed under the terms of the GNU General Public License v2++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE UnicodeSyntax, ViewPatterns, LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module ExRender.Dependency () where++import Distribution.Text+import Distribution.Package+import Distribution.Version++import ExRender.Base++instance ExRender LowerBound where+    exDisp (LowerBound v InclusiveBound) = ">=" <> disp v+    exDisp (LowerBound v ExclusiveBound) = ">" <> disp v++instance ExRender UpperBound where+    exDisp (UpperBound v InclusiveBound) = "<=" <> disp v+    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.+--+-- >>> map maybeExVersion $ asVersionIntervals (fromJust $ simpleParse ">=1.0 || ==0.1.*" :: VersionRange)+-- [Just =0.1*,Just >=1.0]+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 $ text "~>" <> disp v+            where a' = init a++    _ → Nothing++-- | Transform VersionInterval in a sequence of disjunctions+--+-- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0" :: VersionRange)+-- [[>=1.0]]+-- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0 && <1.3" :: VersionRange)+-- [[=1.0*,=1.1*,=1.2*]]+-- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1.0 && <=1.3" :: VersionRange)+-- [[=1.0*,=1.1*,=1.2*,=1.3]]+-- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1 && <=1.3" :: VersionRange)+-- [[=1,=1.0*,=1.1*,=1.2*,=1.3]]+-- >>> map exVersions $ asVersionIntervals (fromJust $ simpleParse ">=1 && <=1.0.3" :: VersionRange)+-- [[=1,=1.0,=1.0.0*,=1.0.1*,=1.0.2*,=1.0.3]]+exVersions ∷ VersionInterval → [Doc]+exVersions = \case+    (maybeExVersion → Just x) → [x]++    -- ... && <=x.b+    (lb, UpperBound v InclusiveBound) →+        exVersions (lb, UpperBound v ExclusiveBound) ++ [char '=' <> disp v]++    -- >=x.a && <x.b+    (LowerBound va@(Version a _) InclusiveBound, ub@(UpperBound (Version b _) ExclusiveBound))+        | init a == init b → do+            c ← [init a ++ [i] | i ← [last a .. last b - 1]]+            return $ char '=' <> disp (Version c []) <> char '*'+        | length a < length b →+            char '=' <> disp va : exVersions (LowerBound (Version (a ++ [0]) []) InclusiveBound, ub)+    _ → []++instance ExRender VersionInterval where+    exDisp (LowerBound (Version [0] []) InclusiveBound, NoUpperBound) = empty+    exDisp (maybeExVersion → Just exVi) = exVi+    exDisp (lb, ub) = exDisp lb <> char '&' <> exDisp ub++instance ExRender VersionRange where+    exDisp vr = case asVersionIntervals vr of+        [vi] → nbrackets $ exDisp vi+        (concatMap exVersions → exVis) | not $ null exVis → nbrackets . hcat $ punctuate (char '|') exVis+        _ → error $ "Unsupported version range: " ++ display vr++instance ExRender Dependency where+    exDisp (Dependency n vr) = "dev-haskell/" <> disp n <> exDisp vr++-- $setup+--+-- >>> import Data.Maybe+--+-- doctest examples:+--+-- >>> exDisp (fromJust $ simpleParse ">=1.0 && <1.3" :: VersionRange)+-- [>=1.0&<1.3]+-- >>> exDisp (fromJust $ simpleParse ">=1.1 && <2" :: VersionRange)+-- [~>1.1]+-- >>> exDisp (fromJust $ simpleParse "==1.* || ==3.*" :: VersionRange)+-- [=1*|=3*]+-- >>> exDisp (fromJust $ simpleParse "==1.1.* || ==1.0.* || ==0.11.*" :: VersionRange)+-- [=0.11*|=1.0*|=1.1*]

@@ -0,0 +1,37 @@+-- Copyright © 2015 Mykola Orliuk <virkony@gmail.com>+-- Distributed under the terms of the GNU General Public License v2++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE FlexibleInstances #-}++module ExRender.Haddock () where++import ExRender.Base++import Documentation.Haddock.Parser+import Documentation.Haddock.Types++instance ExRender Identifier where exDisp (_, s, _) = text s+instance ExRenderQ Identifier where exDispQ = exDisp++instance ExRenderQ id => ExRenderQ (DocH mod id) where+    exDispQ x = case x of+        DocEmpty → empty+        DocAppend a b → exDispQ a <> exDispQ b+        DocString s → exDispQ s+        DocParagraph a → exDispQ a+        DocIdentifier s → exDispQ s+        DocModule s → exDispQ s+        DocWarning a → exDispQ a+        DocEmphasis a → exDispQ a+        DocMonospaced a → exDispQ a+        DocBold a → exDispQ a+        DocHyperlink (Hyperlink _ (Just s)) → exDispQ s+        DocHyperlink (Hyperlink s Nothing) → exDispQ s+        DocPic _ → empty -- XXX: no images in description+        DocAName s → exDispQ s+        DocProperty s → exDispQ s+        DocExamples _ → empty -- XXX: examples are filtered out+        _ → error $ "Unsupported haddock node"

@@ -0,0 +1,37 @@+-- Copyright © 2015 Mykola Orliuk <virkony@gmail.com>+-- Distributed under the terms of the GNU General Public License v2++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}++module ExRender.License () where++import Distribution.Text+import Distribution.License++import ExRender.Base++exKnownLicenses ∷ [String]+exKnownLicenses = ["CC0", "AGPL-3"]++instance ExRender License where+    exDisp (GPL Nothing) = "Unspecified-GPL"+    exDisp (GPL (Just v)) = "GPL-" <> disp v+    exDisp (AGPL (Just v)) = "AGPL-" <> disp v+    exDisp (LGPL Nothing) = "Unspecified-LGPL"+    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+    exDisp x = error $ "Unsupported license: " ++ display x

@@ -1,7 +1,9 @@ -- Copyright © 2015 Mykola Orliuk <virkony@gmail.com> -- Distributed under the terms of the GNU General Public License v2 -{-# LANGUAGE ViewPatterns, UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns, LambdaCase, UnicodeSyntax #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}  module Main where @@ -9,9 +11,11 @@ import Control.Concurrent (threadDelay) import Control.Exception import Data.Maybe+import Data.Default import Data.ByteString.Lazy.Char8 (unpack) -import System.Environment+import Options.Applicative+ import System.IO  import Distribution.Text@@ -24,10 +28,19 @@ import Network.HTTP.Client import Network.HTTP.Types +import Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>), empty, text) import qualified Text.Regex.PCRE.Light.Char8 as R  import ExRender +maybeReader ∷ (String → Maybe a) → ReadM a+maybeReader f = eitherReader $ \case+    (f → Just x) → return x+    arg → Left $ "cannot parse value `" ++ arg ++ "'"++textAuto ∷ Text a ⇒ ReadM a+textAuto = maybeReader simpleParse+ -- |Fetch content by provided URI simpleFetch ∷ String → IO String simpleFetch url = do@@ -98,46 +111,86 @@     ParseOk _ descr ← liftM parsePackageDescription $ simpleFetch url     fixLicense descr +data TargetCabal = TargetCabalFile FilePath+                 | TargetPackage PackageIdentifier+                 | TargetInvalid String+    deriving (Show)++targetParse ∷ String → Either String TargetCabal+targetParse arg = case arg of+    ('.':_) → return $ TargetCabalFile arg+    ('/':_) → return $ TargetCabalFile arg+    (simpleParse → Just pkgId) → return $ TargetPackage pkgId+    _ → Left $ "Specified target " ++ show arg+        ++ " neither starts with '.' or '/' (local cabal file)"+        ++ " nor a valid packageIdentifier (to fetch from hackage)"++targetArguments ∷ Parser [TargetCabal]+targetArguments = some (argument targetReader (metavar "TARGETS..."))+    where targetReader = eitherReader targetParse++data ExCabal =+    ExCabal+        { ghcVersion ∷ Version+        , targets ∷ Maybe [TargetCabal]+        }+    deriving (Show)++exCabalParser ∷ Parser ExCabal+exCabalParser = ExCabal+    <$> option textAuto+        ( long "ghc" <> short 'V'+        <> metavar "VERSION"+        <> help "Target VERSION of GHC"+        <> showDefaultWith display+        <> value (exGHCVersion def)+        )+    <*> optional targetArguments+ main ∷ IO () main = do-    args ← getArgs-    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+    let opts = info (helper <*> exCabalParser)+            ( fullDesc+            <> headerDoc (Just helpHeader)+            <> progDescDoc (Just helpDesc)+            <> footerDoc (Just helpFooter)+            )+    params ← execParser opts+    let env = def { exGHCVersion = ghcVersion params }+    targets' ← case targets params of+        Just xs → return xs+        Nothing →+            liftM (map (either TargetInvalid id . targetParse) . lines) getContents +    let generate source getDescr = do+            let handler ∷ SomeException → IO ()+                handler e = hPutStrLn stderr $ "# Failed fetch/generate for " ++ show source ++ ": " ++ show e+            hPutStrLn stderr $ "# Processing " ++ show source+            catch (liftM (exRenderPkg env) getDescr >>= 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"+    forM_ targets' $ \case+        TargetInvalid err → hPutStrLn stderr $ "# Invalid target: " ++ err+        TargetCabalFile filepath → generate filepath (readPackageDescription verbose filepath >>= fixLicense)+        TargetPackage pkgId → generate (display pkgId) (fetchPackageDescription pkgId)+++helpHeader ∷ Doc+helpHeader = fillSep [+  "Generate package description", "from .cabal files",+  "in format of exheres-0", "for Exherbo Linux"]++helpDesc ∷ Doc+helpDesc = fillSep [+  "Each of TARGETS specify either", "a package name (mtl) at Hackage",+  "with optional", "version (mtl-2.2.1)",+  "or path to local cabal file (./exherbo-cabal.cabal).",+  "If no TARGETS provided in args read them from standart input."]++helpFooter ∷ Doc+helpFooter = vcat ["Examples:", indent 2 $ vcat [+  "> exherbo-cabal mtl-2.2.1",+  "> exherbo-cabal mtl transformers",+  "> echo yesod-core | exherbo-cabal",+  "> exherbo-cabal ./exherbo-cabal.cabal",+  "> find /tmp/index -name \\*.cabal | exherbo-cabal"+  ], mempty, "See https://github.com/ony/exherbo-cabal"]

@@ -1,2 +1,16 @@+import Data.List import Test.DocTest-main = doctest ["-isrc", "src/ExRender.hs"]++sources =+    [ "src/ExRender.hs"+    , "src/ExRender/Base.hs"+    , "src/ExRender/Dependency.hs"+    , "src/ExRender/Haddock.hs"+    , "src/ExRender/License.hs"+    , "src/Main.hs"+    ]++optarg _ [] = []+optarg x ys = x : intersperse x ys++main = doctest $ optarg "-isrc" sources