diff --git a/exherbo-cabal.cabal b/exherbo-cabal.cabal --- a/exherbo-cabal.cabal +++ b/exherbo-cabal.cabal @@ -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. diff --git a/src/ExRender.hs b/src/ExRender.hs --- a/src/ExRender.hs +++ b/src/ExRender.hs @@ -1,214 +1,65 @@ -- Copyright © 2015 Mykola Orliuk -- 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 - (lb, NoUpperBound) → Just $ exDisp lb - - (LowerBound (Version [] _) _, _) → Nothing - (_, UpperBound (Version [] _) _) → Nothing - -- >=x.y && =x.y.z && 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 && 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 " + , "# 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 ", - "# 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*]" diff --git a/src/ExRender/Base.hs b/src/ExRender/Base.hs new file mode 100644 --- /dev/null +++ b/src/ExRender/Base.hs @@ -0,0 +1,74 @@ +-- Copyright © 2015 Mykola Orliuk +-- 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 diff --git a/src/ExRender/Dependency.hs b/src/ExRender/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/ExRender/Dependency.hs @@ -0,0 +1,115 @@ +-- Copyright © 2015 Mykola Orliuk +-- 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 + (lb, NoUpperBound) → Just $ exDisp lb + + (LowerBound (Version [] _) _, _) → Nothing + (_, UpperBound (Version [] _) _) → Nothing + -- >=x.y && =x.y.z && " <> 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 && 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*] diff --git a/src/ExRender/Haddock.hs b/src/ExRender/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/ExRender/Haddock.hs @@ -0,0 +1,37 @@ +-- Copyright © 2015 Mykola Orliuk +-- 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" diff --git a/src/ExRender/License.hs b/src/ExRender/License.hs new file mode 100644 --- /dev/null +++ b/src/ExRender/License.hs @@ -0,0 +1,37 @@ +-- Copyright © 2015 Mykola Orliuk +-- 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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,9 @@ -- Copyright © 2015 Mykola Orliuk -- 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 | ... ]\n"++ - " -h | --help Print this help and exit\n" ++ - " 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 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"] diff --git a/src/doctests.hs b/src/doctests.hs --- a/src/doctests.hs +++ b/src/doctests.hs @@ -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