diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Omari Norman +Copyright (c) 2014 - 2015, Omari Norman All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,11 @@ http://www.github.com/massysett/cartel -## Testing +## Test results -There are no tests for this library. If you hit any bugs, please -report them in the Github issue tracker so I can fix them. +[![Build Status](https://travis-ci.org/massysett/cartel.svg?branch=master)](https://travis-ci.org/massysett/cartel) + +If you have trouble getting Cartel to build, you might try looking at +the test results by clicking on the button above; archived test +results will show you what package dependencies have been used in the +past to build Cartel successfully. diff --git a/cartel.cabal b/cartel.cabal --- a/cartel.cabal +++ b/cartel.cabal @@ -2,54 +2,118 @@ -- Cartel is available at: -- http://www.github.com/massysett/cartel -- --- Script name used to generate: genCabal.hs --- Generated on: 2014-05-30 14:59:50.352284 EDT --- Cartel library version: 0.10.0.0 +-- Script name used to generate: GenCartelCabal.hs +-- Generated on: 2015-01-17 18:01:46.377337 EST +-- Cartel library version: 0.12.0.0 name: cartel -version: 0.10.0.2 -cabal-version: >= 1.14 -build-type: Simple +version: 0.12.0.0 +cabal-version: >= 1.16 license: BSD3 license-file: LICENSE -copyright: 2014 Omari Norman +build-type: Simple +copyright: Copyright 2014-2015 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental homepage: http://www.github.com/massysett/cartel -bug-reports: omari@smileystation.com -synopsis: Specify your Cabal files in Haskell +bug-reports: http://www.github.com/massysett/cartel/issues +synopsis: Specify Cabal files in Haskell description: - By specifying Cabal files in Haskell, you have the power - of Haskell at your disposal to eliminate redundancies - and to programatically populate various fields. + By specifying your Cabal files in Haskell, you have the power + of Haskell at your disposal to reduce redundancy. You can + also read in trees of module names dynamically, which saves + you from manually maintaining lists of module names. . See the documentation in the "Cartel" module for details. category: Distribution -tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.2 +tested-with: + GHC == 7.6.3 + , GHC == 7.8.2 extra-source-files: README.md - , genCabal.hs - , current-versions.txt - , minimum-versions.txt Library exposed-modules: Cartel , Cartel.Ast - , Cartel.Empty + , Cartel.Betsy + , Cartel.Betsy.Internal + , Cartel.GenCartelCabal , Cartel.Render - , Cartel.Tools - exposed: True + , Cartel.Types + , Cartel.Version + default-language: Haskell2010 + ghc-options: + -Wall + hs-source-dirs: + lib build-depends: base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) - , time ((> 1.4 || == 1.4) && < 1.5) + , time ((> 1.4 || == 1.4) && < 1.6) + , transformers ((> 0.4 || == 0.4) && < 0.5) + +source-repository head + type: git + location: https://github.com/massysett/cartel.git + +Executable cartel-visual-test + if flag(visual) + buildable: True + other-modules: + Cartel.Generators + , Cartel.Properties + , Decrees + hs-source-dirs: + tests + build-depends: + multiarg ((> 0.30.0.0 || == 0.30.0.0) && < 0.31) + , QuickCheck ((> 2.7 || == 2.7) && < 2.8) + , random ((> 1.1 || == 1.1) && < 1.2) + , quickpull ((> 0.4.0.0 || == 0.4.0.0) && < 0.5) + ghc-options: + -Wall + hs-source-dirs: + lib + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + , time ((> 1.4 || == 1.4) && < 1.6) + , transformers ((> 0.4 || == 0.4) && < 0.5) + else + buildable: False + default-language: Haskell2010 + main-is: cartel-visual-test.hs + +Test-Suite cartel-properties + default-language: Haskell2010 other-modules: - Paths_cartel - buildable: True + Cartel.Generators + , Cartel.Properties + , Decrees + hs-source-dirs: + tests + build-depends: + multiarg ((> 0.30.0.0 || == 0.30.0.0) && < 0.31) + , QuickCheck ((> 2.7 || == 2.7) && < 2.8) + , random ((> 1.1 || == 1.1) && < 1.2) + , quickpull ((> 0.4.0.0 || == 0.4.0.0) && < 0.5) ghc-options: -Wall - default-language: Haskell2010 hs-source-dirs: lib + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + , time ((> 1.4 || == 1.4) && < 1.6) + , transformers ((> 0.4 || == 0.4) && < 0.5) + type: exitcode-stdio-1.0 + main-is: cartel-properties.hs + +Flag visual + description: Build cartel-visual-test executable. + default: False + manual: True diff --git a/current-versions.txt b/current-versions.txt deleted file mode 100644 --- a/current-versions.txt +++ /dev/null @@ -1,38 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the default versions fetched by cabal install. -Tested as of: 2014-05-30 16:15:53.772569 UTC -Path to compiler: ghc-7.8.2 -Compiler description: 7.8.2 - -/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d: - Cabal-1.18.1.3 - array-0.5.0.0 - base-4.7.0.0 - bin-package-db-0.0.0.0 - binary-0.7.1.0 - rts-1.0 - bytestring-0.10.4.0 - containers-0.5.5.1 - deepseq-1.3.0.2 - directory-1.2.1.0 - filepath-1.3.0.2 - (ghc-7.8.2) - ghc-prim-0.3.1.0 - (haskell2010-1.1.2.0) - (haskell98-2.0.0.3) - hoopl-3.10.0.1 - hpc-0.6.0.1 - integer-gmp-0.5.1.0 - old-locale-1.0.0.6 - old-time-1.1.0.2 - pretty-1.1.1.1 - process-1.2.0.0 - template-haskell-2.9.0.0 - time-1.4.2 - transformers-0.3.0.0 - unix-2.7.0.1 - -/home/massysett/cartel/sunlight-11214/db: - cartel-0.10.0.0 - diff --git a/genCabal.hs b/genCabal.hs deleted file mode 100644 --- a/genCabal.hs +++ /dev/null @@ -1,123 +0,0 @@ --- | This is a Cartel program used to generate the cabal file for --- Cartel itself. --- --- You should note in your comments which version of Cartel was used --- when writing the Cartel program; in this case, I used version --- 0.10.0.0. --- --- There's no huge benefit to using Cartel for small programs or --- libraries; indeed, Cartel itself is small so there's not much --- benefit to using Cartel here other than for pedagogical and --- testing purposes. Cartel is most useful for big Cabal files with --- lots of redundancy and dozens of modules. -module Main (main) where - --- Cartel exports a lot of names; by importing them qualified you --- don't have to worry about clashing with your own names - -import qualified Cartel as A - --- Package Dependencies --- --- It can be useful to pull these out and define them in --- top-level values, especially if your Cabal file has many --- redundancies. That way you can update version numbers in just --- one place rather than throughout your Cabal file (forgetting to --- update all these numbers is a major reason I wrote Cartel.) - -base :: A.Package -base = A.closedOpen "base" [4,5,0,0] [4,8] - -directory :: A.Package -directory = A.closedOpen "directory" [1,1,0,2] [1,3] - -filepath :: A.Package -filepath = A.closedOpen "filepath" [1,3,0,0] [1,4] - -time :: A.Package -time = A.closedOpen "time" [1,4] [1,5] - -testedWith :: [(A.Compiler, A.ConstrTree)] -testedWith = - let ghc v = (A.GHC, A.Leaf (A.Constraint EQ (A.Version v))) - in map ghc [[7,4,1], [7,6,3], [7,8,2]] - --- The global package properties. Build your properties from the --- default 'properties' record rather than the 'Properties' --- constructor to help future-proof your code. - -properties :: A.Properties -properties = A.empty - { A.prName = "cartel" - , A.prVersion = A.Version [0,10,0,2] - , A.prCabalVersion = (1, 14) - , A.prBuildType = A.Simple - , A.prLicense = A.BSD3 - , A.prLicenseFile = "LICENSE" - , A.prLicenseFiles = [] - , A.prExtraSourceFiles = - [ "README.md" - , "genCabal.hs" - , "current-versions.txt" - , "minimum-versions.txt" ] - , A.prTestedWith = testedWith - , A.prCopyright = "2014 Omari Norman" - , A.prAuthor = "Omari Norman" - , A.prMaintainer = "omari@smileystation.com" - , A.prStability = "Experimental" - , A.prHomepage = "http://www.github.com/massysett/cartel" - , A.prBugReports = "omari@smileystation.com" - , A.prSynopsis = "Specify your Cabal files in Haskell" - , A.prDescription = - [ "By specifying Cabal files in Haskell, you have the power" - , "of Haskell at your disposal to eliminate redundancies" - , "and to programatically populate various fields." - , "" - , "See the documentation in the \"Cartel\" module for details." - ] - , A.prCategory = "Distribution" - } - --- Definition for the library. It takes a list of modules to export --- as a parameter; this allows the Main function to use a function --- to generate the list of modules rather than you having to specify --- them in a duplicative, error-prone, and boring process. - -library - :: [String] - -- ^ List of library modules to export - -> A.Library -library ms = A.Library $ - [ A.LibExposedModules ms - , A.LibExposed True - ] - - ++ map A.LibInfo - - [ A.BuildDepends [base, directory, filepath, time] - , A.OtherModules ["Paths_cartel"] - , A.Buildable True - , A.GHCOptions ["-Wall"] - , A.DefaultLanguage A.Haskell2010 - , A.HsSourceDirs ["lib"] - ] - - --- Generate the complete Cabal record - -cabal - :: [String] - -- ^ List of library modules - -> A.Cabal -cabal mods = A.empty - { A.cProperties = properties - , A.cLibrary = Just $ library mods - } - --- To see the result, just run "runhaskell genCabal.hs". The result --- is printed to standard output. - -main :: IO () -main = do - modulesToExport <- A.modules "lib" - A.render "genCabal.hs" $ cabal modulesToExport diff --git a/lib/Cartel.hs b/lib/Cartel.hs --- a/lib/Cartel.hs +++ b/lib/Cartel.hs @@ -16,42 +16,332 @@ -- of modules and use the result, thus avoiding the need to manually -- update your module lists. -- --- A disadvantage to Cartel is that it can be a bit more verbose --- than a vanilla Cabal file. In addition, you also have to --- remember to generate the new Cabal file whenever you change the --- script that generates your Cabal file. +-- A disadvantage to Cartel is that is more verbose than a vanilla +-- Cabal file. In addition, you also have to remember to generate the +-- new Cabal file whenever you change the script that generates your +-- Cabal file. -- --- Cabal already has an AST that it uses. Cartel could, perhaps, --- have re-used these structures. Cartel does not do this for three --- reasons. First, the Cabal API is a bit untidy, partially because --- it has to do things that Cartel doesn't have to worry about, but --- also because the comments in the Cabal modules themselves --- indicate that the whole thing could use a refactoring. Second, --- the Cabal developers make no commitment to keep that API stable. --- Third, the Cartel API tries only to replicate format of the --- plain-text Cabal file, which will be much more stable than the --- Cabal API. +-- To the extent possible, Cartel uses the Haskell type system to +-- prevent you from making mistakes in your Cabal file. For example, +-- the 'Betsy' type prevents you from using 'flag's that you have not +-- declared, and you can't put an 'exposedModules' field in anything +-- but a library. However, Cartel does not prevent against all +-- errors. For example, Cartel does nothing to prevent you from +-- applying a function that calls for a 'NonEmptyString' to a string +-- that is, in fact, empty. Another example is that Cabal requires +-- executables to have a @main-is@ field, but Cartel does not force +-- you to include one. Ultimately your Cabal file might still have +-- errors that you have to fix by changing the program that generates +-- the file. -- --- To get started, first study the "Cartel.Ast" module. It contains --- the data types that mirror the structure of a Cabal file. You --- will find that every Cabal feature, including test suites, --- benchmarks, and conditionals, is represented. Then look at --- "Cartel.Tools", which has short functions to make Cartel easier --- to use. "Cartel.Render" has functions to transform "Cartel.Ast" --- types to plain text; the necessary bits from here are exported --- through "Cartel.Tools" so you shouldn't need to use this module --- much if at all. +-- Everything you usually need is in this module. Other Cartel +-- modules contain implementation details. /See first/ the +-- 'NonEmptyString' type synonym, which has important details on how +-- to regard 'String's and 'NonEmptyString's as you read the +-- documentation. Also, examine "Cartel.GenCartelCabal", which +-- generates Cartel's own Cabal file using Cartel. -- --- Also, examine the genCabal.hs file, which generates Cartel's own --- Cabal file using Cartel. To test it out, after installing Cartel --- just run "runhaskell genCabal.hs". +-- Hopefully this module's documentation is organized so that +-- top-to-bottom reading will make sense. module Cartel - ( module Cartel.Ast - , module Cartel.Empty - , module Cartel.Tools + ( -- * Basic types and classes + Word + , NonEmptyString + , Blank(..) + , Version + + -- * Sections + , Section + + -- * Repositories + -- ** Version control systems + , Vcs + , darcs, git, svn, mercurial, bazaar, archVcs, monotone, cvs + + -- ** Repository kinds + , RepoKind + , repoHead, repoThis + -- ** Building repositories + , Repository(..) + , githubHead + , repository + + -- * Logicals + , LogicTree(..) + , invert + + -- ** Constraints + , Constraint + , lt + , gt + , eq + , ltEq + , gtEq + , anyVersion + + -- ** Conditionals + , Compiler + , ghc, nhc, yhc, hugs, helium, jhc, lhc + , Condition + , system + , arch + , impl + , flag + , true + , false + , condBlock + + -- * Packages + , Package + , package + + -- ** Package helpers + , closedOpen + , apiVersion + , nextBreaking + , nextMajor + , exactly + , unconstrained + + -- * Build information + + -- | Libraries, executables, test suites, and benchmarks all share + -- common fields for build information. 'BuildInfoField' represents + -- these common fields, and 'HasBuildInfo' is a typeclass encompassing + -- libraries, executables, test suites, and benchmarks. You can + -- build these fields for any of these sections using the functions + -- and values listed here. + , BuildInfoField + , HasBuildInfo + , haskell98 + , haskell2010 + , buildDepends + , otherModules + , hsSourceDirs + , extensions + , buildTools + , buildable + , ghcOptions + , ghcProfOptions + , ghcSharedOptions + , hugsOptions + , nhc98Options + , includes + , installIncludes + , includeDirs + , cSources + , extraLibraries + , extraLibDirs + , ccOptions + , cppOptions + , ldOptions + , pkgConfigDepends + , frameworks + + -- * BuildsExe + -- + -- | Benchmarks, test suites, and executables have common fields; + -- the 'BuildsExe' class captures these. + , BuildsExe(..) + + -- * Exitcode executables + -- + -- | Test suites and benchmarks are capable of building things of + -- type @exitcode-stdio-1.0@; the 'BuildsExitcode' class reflects + -- this. + , BuildsExitcode(..) + , exitcodeFields + + -- * Betsy + , Betsy + + -- ** Flags + , FlagName + , FlagOpts(..) + , makeFlag + , currentFlags + + -- * Libraries + -- + -- | A library consists of one or more 'LibraryField's. Typically + -- you will return these fields inside of the 'Betsy' type through + -- the 'defaultMain' function. To build a 'LibraryField', you will + -- mostly use the bindings in the \"Build Information\" section of + -- this module. You will also need 'exposedModules' and you might + -- use 'exposed' and 'condBlock'. + , LibraryField + , exposed + , exposedModules + + -- * Executables + -- + -- | An executable consists of one more more 'ExecutableField's. + -- You build an executable by passing one or more 'ExecutableField's + -- to the 'executable' function. To get an 'ExecutableField', you + -- will mostly use the bindings in the \"Build Information\" section + -- of this module, as well as 'mainIs'. You might also need + -- 'condBlock'. + , ExecutableField + , executable + + -- * Test suites + -- + -- | A test suite consists of one more more 'TestSuiteField's. You + -- build an test suite by passing one or more 'TestSuiteField's to + -- the 'testSuite' function. To get a 'TestSuiteField', you will + -- mostly use the bindings in the \"Build Information\" section of + -- this module. You might also need the 'testModule', + -- 'exitcodeStdio', 'mainIs', 'detailed', 'condBlock', and + -- 'exitcodeFields' bindings. + , detailed + , TestSuiteField + , testModule + , testSuite + + -- * Benchmarks + -- + -- | A benchmark consists of one more more 'BenchmarkField's. You + -- build an benchmark by passing one or more 'BenchmarkField's to + -- the 'benchmark' function. To get an 'BenchmarkField', you will + -- mostly use the bindings in the \"Build Information\" section of + -- this module. You might also need the 'exitcodeStdio', + -- 'exitcodeFields', and 'condBlock' bindings. + , BenchmarkField + , benchmark + + -- * Getting module lists + , fileExtensions + , modulesWithExtensions + , modules + + -- * Properties + -- ** Build types + , BuildType + , simple, configure, make, custom + -- ** Licenses + , License + , gpl, agpl, lgpl, bsd2, bsd3, bsd4, mit, mpl, apache, publicDomain + , allRightsReserved, otherLicense + , Properties(..) + + -- * Cabal file + -- + -- | Usually you will not need this type, as 'defaultMain' produces + -- a 'Cabal' value for you, but you will need it if you want to use + -- 'bestyToCabalString'. + , Cabal + , cabal + + -- * Generating Cabal files + -- ** defaultMain - usually all you need + , defaultMain + + -- ** Other bindings - for more unusual uses + , Error(..) + , Renderable(..) + , RenderableIndented(..) + , renderBetsy + , betsyToCabalStringIO + ) where +-- # begin imports + import Cartel.Ast -import Cartel.Empty -import Cartel.Tools +import Cartel.Render +import qualified System.IO as IO +import Data.Time +import qualified Cartel.Version +import Data.List (intersperse) +import System.Exit (exitFailure, exitSuccess) +import System.Environment (getProgName) +import Data.Word +import Control.Monad.IO.Class +import Cartel.Betsy +import Cartel.Types + +-- # end imports + +-- | Pure function to obtain Cabal text. +renderBetsy + :: Functor m + => Betsy m Cabal + -> m (Either Error String) + -- ^ Returns either an error message or the generated Cabal text. +renderBetsy = fmap k . runBetsy + where + k ei = case ei of + Left e -> Left e + Right (cbl, fls) -> Right + . vsep + $ [ renderIndented 0 cbl + , renderIndented 0 fls ] + +-- | Renders a header for the Cabal file. +header + :: String + -- ^ Name of program used + -> ZonedTime + -- ^ When this output is being created + -> String +header nm zt = hdr + where + hdr = unlines $ + [ "-- This Cabal file generated using the Cartel library." + , "-- Cartel is available at:" + , "-- http://www.github.com/massysett/cartel" + , "--" + ] ++ case nm of + [] -> [] + _ -> ["-- Script name used to generate: " ++ nm] + ++ + [ "-- Generated on: " ++ show zt + , "-- Cartel library version: " ++ showVer + ] + showVer = concat + . intersperse "." + . map show + $ Cartel.Version.version + + +-- | Like 'renderBetsy' but also uses 'IO' to prepend a header +-- that has the name of the program that is running this function, and +-- the current date and time. +betsyToCabalStringIO + :: (MonadIO m, Functor m) + => Betsy m Cabal + -> m (Either Error String) +betsyToCabalStringIO wg = do + ei <- renderBetsy wg + case ei of + Left e -> return $ Left e + Right cbl -> do + pn <- liftIO getProgName + zt <- liftIO getZonedTime + return . Right $ (header pn zt) ++ cbl + + +-- | Generates a Cabal file. If you have no library, just leave the +-- list of 'LibraryField' empty. Include any and all executables, +-- test suites, benchmarks, and repositories in the list of 'Section'. +-- Ensures that the generated Cabal file also includes any flags you +-- made with 'makeFlag'. If there is an error (such as a duplicate +-- flag) an error message is printed to standard error and the program +-- invokes 'exitFailure'; otherwise, the generated Cabal file is +-- printed to standard output and the program invokes 'exitSuccess'. +defaultMain + :: Betsy IO (Properties, [LibraryField], [Section]) + -> IO () +defaultMain wg = do + let conv (p, ls, ss) = Cabal p ls ss + ei <- betsyToCabalStringIO (fmap conv wg) + case ei of + Left e -> do + IO.hPutStrLn IO.stderr . renderIndented 0 $ e + exitFailure + Right str -> do + IO.hSetBinaryMode IO.stdout False + IO.hSetEncoding IO.stdout IO.utf8 + putStr str + exitSuccess diff --git a/lib/Cartel/Ast.hs b/lib/Cartel/Ast.hs --- a/lib/Cartel/Ast.hs +++ b/lib/Cartel/Ast.hs @@ -1,577 +1,1209 @@ --- | An abstract syntax tree for Cabal files. There are thoughts in --- the "Cartel" module documentation on why this wheel is reinvented --- rather than reusing the types already available in the Cabal --- library. --- --- The 'Cabal' data type represents the root of the Cabal file; all --- other types in this file are ultimately components of the 'Cabal' --- type. --- --- Much documentation in this module is copied from the --- /Developing Cabal Packages/ guide at --- --- - -module Cartel.Ast - ( - -- * Constraint trees - Logical(..) - , Version(..) - , Constraint(..) - , ConstrTree(..) - - -- * Global package description - , BuildType(..) - , License(..) - , Compiler(..) - , Properties(..) - - -- * Repositories - , RepoKind(..) - , Vcs(..) - , Repository(..) - - -- * Flags - , Flag(..) - - -- * Build information - , Package(..) - , Language(..) - , BuildInfoField(..) - - -- * Conditionals - , Condition(..) - , CondTree(..) - , CondBlock(..) - - -- * Libraries - , LibraryField(..) - , Library(..) - - -- * Executables - , ExecutableField(..) - , Executable(..) - - -- * Test suites - , TestSuiteType(..) - , TestSuiteField(..) - , TestSuite(..) - - -- * Benchmarks - , BenchmarkField(..) - , Benchmark(..) - - -- * Cabal - , Cabal(..) - - ) where - --- | A version number. The Cabal documentation says this --- \"usually\" consists of a sequence of natural numbers separated --- by dots. Though this suggests that a version number could --- contain something other than natural numbers, in fact the types --- in the Cabal library do not allow anything other than numbers and --- you will get a parse error if you try to use anything else. --- --- Therefore Cartel's 'Version' type only allows a list of 'Int' in --- a version number. -newtype Version = Version { unVersion :: [Int] } - deriving (Eq, Ord, Show) - -data BuildType - = Simple - | Configure - | Make - | Custom - deriving (Eq, Ord, Show) - -data License - = GPL - | AGPL - | LGPL - | BSD2 - | BSD3 - | BSD4 - | MIT - | MPL - | Apache - | PublicDomain - | AllRightsReserved - | OtherLicense - deriving (Eq, Ord, Show) - -data Compiler - = GHC - | NHC - | YHC - | Hugs - | Helium - | JHC - | LHC - deriving (Eq, Ord, Show) - --- | A version constraint; used primarily when specifying the build --- dependencies of a package. For example, to specify --- @less than version 1.0@, use @Constraint LT (Version [1,0])@. --- --- There is no way to express @less than or equal to@ or @greater --- than or equal to@; for that, use 'ConstrTree'. -data Constraint = Constraint - { csComparison :: Ordering - , csVersion :: Version - } deriving (Eq, Ord, Show) - -data Logical - = Or - | And - deriving (Eq, Ord, Show) - --- | Expresses a tree of constraints. This is how you represent --- more complex dependency relationships. For example, to represent --- @less than or equal to version 1.0@, use --- --- >> let one = Version [1,0] --- >> in Branch Or (Constraint LT one) (Constraint EQ one) --- --- Combinators in "Cartel.Tools" help you build the most common --- cases. -data ConstrTree - = Leaf Constraint - | Branch Logical ConstrTree ConstrTree - deriving (Eq, Ord, Show) - --- | Global package properties. Most of the 'String' fields are --- optional; to leave them blank, use the empty string. To future --- proof your code, use 'Cartel.Empty.empty', which provides --- this record already filled in with default values (which are --- typically blank.) Then you only alter the fields you wish to --- fill in. - -data Properties = Properties - { prName :: String - -- ^ Unique name of package, without the version number - - , prVersion :: Version - -- ^ Package version number - - , prCabalVersion :: (Int, Int) - -- ^ Version of Cabal that the package uses; for instance, for - -- 1.20, use @(1, 20) - - , prBuildType :: BuildType - - , prLicense :: License - - , prLicenseFile :: String - -- ^ The file containing the precise copyright license - - , prLicenseFiles :: [String] - -- ^ Multiple license files; use in addition to, or instead of, - -- 'prLicenseFile' - - , prCopyright :: String - -- ^ Copyright notice; typically the name of the holder of the - -- copyright and the year(s) for which copyright is claimed - - , prAuthor :: String - -- ^ Original package author - - , prMaintainer :: String - -- ^ Current package maintainer; this is an email address to which - -- users should send bug reports, feature requests, and patches. - - , prStability :: String - -- ^ Package stability level, e.g. @alpha@, @stable@, etc. - - , prHomepage :: String - -- ^ URL of package homepage - - , prBugReports :: String - -- ^ URL where users should direct bug reports. Should be either - -- a @mailto:@ URL for a person or mailing list, or an @http:@ or - -- @https:@ URL for an online bug tracking system. - - , prPackageUrl :: String - -- ^ The location of a source bundle for the package. - - , prSynopsis :: String - -- ^ Short, one-line synopsis of what the package does - - , prDescription :: [String] - -- ^ Each line of the long description. Do not include the - -- newlines themselves. If you wish to include a blank line, - -- include a list item that is the empty string; upon rendering, a - -- single period will be inserted, as Cabal requires when - -- inputting blank lines. - - , prCategory :: String - -- ^ A comma-separated list of categories to use on Hackage. - - , prTestedWith :: [(Compiler, ConstrTree)] - -- ^ Compilers and versions against which the package has been - -- tested. - - , prDataFiles :: [String] - -- ^ List of files to be installed for run-time use by the - -- package. - - , prDataDir :: String - -- ^ The directory where Cabal looks for data files to install, - -- relative to the source directory. By default Cabal looks in - -- the source directory itself. - - , prExtraSourceFiles :: [String] - -- ^ List of additional files to be included in source - -- distributions built with @setup sdist@. This can use a limited - -- form of @*@ wildcards in file names. - - , prExtraDocFiles :: [String] - -- ^ List of additional files to be included in source - -- distributions, and also copied to the html directory when - -- Haddock documentation is generated. As with data-files it can - -- use a limited form of @*@ wildcards in file names. - - , prExtraTmpFiles :: [String] - -- ^ List of additional files or directories to be removed by - -- @setup clean@. These would typically be additional files - -- created by additional hooks. - - } deriving (Eq, Ord, Show) - --- | A field in the @Library@ section of the Cabal file. A --- @Library@ section can have multiple fields. -data LibraryField - = LibExposedModules [String] - -- ^ Exposed modules. 'Cartel.Tools.modules' can help you - -- generate this. - - | LibExposed Bool - -- ^ Is the library exposed? GHC can hide libraries. - - | LibConditional (CondBlock LibraryField) - -- ^ The @Library@ section can contain conditional blocks. - - | LibInfo BuildInfoField - -- ^ The @Library@ section can contain build information. - deriving (Eq, Ord, Show) - --- | The entire @Library@ section. -newtype Library = Library - { libFields :: [LibraryField] - } deriving (Eq, Ord, Show) - --- | A single field in an @Executable@ section. An @Executable@ --- section may have multiple fields. -data ExecutableField - - = ExeMainIs String - -- ^ @main-is@. This field is required. - - | ExeConditional (CondBlock ExecutableField) - -- ^ An @Executable@ section can contain conditional blocks. - - | ExeInfo BuildInfoField - -- ^ An @Executable@ section can contain one or more build - -- information fields. - - deriving (Eq, Ord, Show) - --- | An entire @Executable@ section. -data Executable = Executable - { exeName :: String - -- ^ The name of the executable that Cabal will build. - , exeFields :: [ExecutableField] - -- ^ Zero or more fields associated with this executable. - } deriving (Eq, Ord, Show) - --- | What kind of test suite is this? -data TestSuiteType - = ExitcodeStdio - -- ^ An @exitcode-stdio-1.0@ test. The @String@ is the name of - -- the file containing the executable code. In this case, the - -- 'TestMainIs' field is required. - - | Detailed - -- ^ The @detailed-1.0@ test. In this case, the 'TestModule' - -- field is required. - deriving (Eq, Ord, Show) - --- | A single field value in a test suite section. A single test --- suite section may contain mulitple fields. -data TestSuiteField - = TestType TestSuiteType - -- ^ What kind of test this is - - | TestMainIs String - -- ^ The name of the @.hs@ or @.lhs@ file containing the @Main@ - -- module. The @.hs@ filename must be listed, even if that file - -- is generated with a preprocessor. The file must be relatie to - -- one of the directories listed in 'HsSourceDirs'. This field - -- is required when using 'ExitcodeStdio' and disallowed when - -- using 'Detailed'. - - | TestModule String - -- ^ The module exporting the @tests@ symbol. This field is - -- required when using 'Detailed' and disallowed when using - -- 'ExitcodeStdio'. - - | TestConditional (CondBlock TestSuiteField) - -- ^ A test may contain zero or more conditional blocks. - - | TestInfo BuildInfoField - -- ^ A test suite can contain build information fields. - - deriving (Eq, Ord, Show) - --- | An entire test suite section. -data TestSuite = TestSuite - { tsName :: String - -- ^ The executable name of the resulting test suite - , tsFields :: [TestSuiteField] - -- ^ Zero or more fields configuring the test. - } deriving (Eq, Ord, Show) - --- | A single field in a @Benchmark@ section. Because Cabal --- currently supports only one benchmark interface, which is --- @exitcode-stdio-1.0@, all Cartel-generated files using benchmarks --- will have benchmarks of this type. -data BenchmarkField - = BenchmarkConditional (CondBlock BenchmarkField) - -- ^ A benchmark can have conditional blocks. - | BenchmarkInfo BuildInfoField - -- ^ A benchmark can have build information fields. - deriving (Eq, Ord, Show) - -data Benchmark = Benchmark - { bmName :: String - -- ^ The name of the benchmark that will be built - , bmMainIs :: String - -- ^ The @.hs@ or @.lhs@ file containing the @Main@ module. - , bmFields :: [BenchmarkField] - -- ^ Zero or more benchmark fields. - } deriving (Eq, Ord, Show) - --- | A single package, consisting of a package name and an optional --- set of constraints. Used when specifying 'BuildDepends', --- 'BuildTools', and 'PkgConfigDepends'. -data Package = Package - { packName :: String - , packConstraints :: Maybe ConstrTree - } deriving (Eq, Ord, Show) - --- | Default language. Currently not documented in Cabal docs, see --- --- -data Language - = Haskell98 - | Haskell2010 - deriving (Eq, Ord, Show) - --- | A single field of build information. This can appear in a --- Library, Executable, Test-Suite, or Benchmark. -data BuildInfoField - = BuildDepends [Package] - -- ^ A list of packages needed to build this component - - | OtherModules [String] - -- ^ Modules used but not exposed. For libraries, these are - -- hidden modules; for executable, these are auxiliary modules to - -- be linked with the file in the @main-is@ field. - -- - -- 'Cartel.Tools.modules' can help greatly with maintenance of - -- this field. - - | HsSourceDirs [String] - -- ^ Root directories for the module hierarchy - - | Extensions [String] - -- ^ Haskell extensions used by every module. - - | BuildTools [Package] - -- ^ Programs needed to build this package, such as c2hs. - - | Buildable Bool - -- ^ Is this component buildable? - - | GHCOptions [String] - | GHCProfOptions [String] - | GHCSharedOptions [String] - | HugsOptions [String] - | Nhc98Options [String] - | Includes [String] - -- ^ Header files to be included in any compilations via C. - -- Applies to both header files that are already installed on the - -- system and to those coming with the package to be installed. - - | InstallIncludes [String] - -- ^ Header files to be installed into @$libdir/includes@ when the - -- package is installed. These files should be found in relative - -- to the top of the source tree or relative to one of the - -- directories listed in @include-dirs@. - - | IncludeDirs [String] - -- ^ List of diretories to search for header files when dealing - -- with C compilations. - - | CSources [String] - -- ^ C sources to be compiled and lined with the Haskell files. - - | ExtraLibraries [String] - -- ^ Extra libraries to link with. - - | ExtraLibDirs [String] - -- ^ Directories to search for libraries. - - | CCOptions [String] - -- ^ C Compiler options. - - | CPPOptions [String] - -- ^ C Preprocessor options. Undocumented, see - -- - - | LDOptions [String] - -- ^ Linker options. - - | PkgConfigDepends [Package] - -- ^ List of pkg-config packages needed to build this component. - - | Frameworks [String] - -- ^ OS X frameworks. - - | DefaultLanguage Language - deriving (Eq, Ord, Show) - --- | Conditions to use in the @if@ statement when defining --- conitional blocks. -data Condition - = OS String - -- ^ Operating system; tested against @System.Info.os@ on the - -- target system. - - | Arch String - -- ^ Argument is matched against @System.Info.arch@ on the target - -- system. - - | Impl (Compiler, Maybe ConstrTree) - -- ^ Tests for the configured Haskell implementation. - - | CFlag String - -- ^ Evaluates to the current assignment of the flag of the given - -- name. Flag names are case insensitive. Testing for flags that - -- have not been introduced with a flag section is an error. - - | CTrue - -- ^ Always true. - - | CFalse - -- ^ Always false. - - deriving (Eq, Ord, Show) - --- | Tree of conditions to use in a 'CondBlock'. -data CondTree - = CLeaf Condition - | CBranch Logical CondTree CondTree - | CNegate CondTree - deriving (Eq, Ord, Show) - --- | An @if-then-else@ block. -data CondBlock a = CondBlock - { condIf :: CondTree - , ifTrue :: [a] - , ifElse :: [a] - } deriving (Eq, Ord, Show) - -instance Functor CondBlock where - fmap f (CondBlock t ts es) = CondBlock t (map f ts) (map f es) - --- | What kind of VCS repository is this? -data RepoKind - - = Head - -- ^ The latest development branch of the repository - - | This - -- ^ The sources for this release of this package. - deriving (Eq, Ord, Show) - -data Vcs - = Darcs - | Git - | Svn - | Cvs String - -- ^ The argument 'String' is the named module - | Mercurial - | Bazaar - | ArchVcs - | Monotone - deriving (Eq, Ord, Show) - -data Repository = Repository - { repoVcs :: Vcs - -- ^ Specifies the version control system in use. - - , repoKind :: RepoKind - -- ^ Whether this is a @head@, which refers to the latest - -- development branch of the package, or a @this@, which contains - -- the sources for this release of the package. - - , repoLocation :: String - -- ^ A URL giving the location of the repository. Will vary by - -- repository type; for git, you may use a @git://@ URL, for - -- example. This field is required. - - , repoBranch :: String - -- ^ For example, CVS, SVN, and git can have multiple branches in - -- a single repository; darcs cannot. If you need to specify a - -- branch, do it here. This field is optional. - - , repoTag :: String - -- ^ A repository tag. It is required for the @this@ repo kind. - -- It is optional for the @head@ repo kind. The tag will often be - -- a version number of some kind and should point the user to the - -- sources in the repo that correspond to a particular package - -- version. - - , repoSubdir :: String - -- ^ Some projects put the sources for multiple packages under a - -- single source repository. This field lets you specify the - -- relative path from the root of the repository to the top - -- directory for the package, ie the directory containing the - -- package’s .cabal file. - -- - -- This field is optional. It defaults to empty which corresponds - -- to the root directory of the repository. - - } deriving (Eq, Ord, Show) - --- | A single flag. -data Flag = Flag - { flName :: String - -- ^ The name of the flag; other parts of the Cabal file refer to - -- the flag using this name. - - , flDescription :: String - -- ^ A description of the flag (typically one line long.) - - , flDefault :: Bool - -- ^ Default value of this flag. - - , flManual :: Bool - -- ^ If True, then Cabal will not change this flag's value as it - -- tries to build the package. If False, then Cabal will first - -- try to satisfy dependencies with the default flag value and - -- then, if that is not possible, with the negated value. - - } deriving (Eq, Ord, Show) - --- | Data for the entire Cabal file. -data Cabal = Cabal - { cProperties :: Properties - , cRepositories :: [Repository] - , cFlags :: [Flag] - , cLibrary :: Maybe Library - , cExecutables :: [Executable] - , cTestSuites :: [TestSuite] - , cBenchmarks :: [Benchmark] - } deriving (Eq, Ord, Show) +-- | The Cartel abstract syntax tree +-- +-- Use this module if you want access to the data constructors in the +-- AST; the functions and values exported through "Cartel" should be +-- enough for most uses. Use of this module will not violate any +-- invariants; this stuff is in a separate module merely for the sake +-- of tidiness of the documentation in "Cartel". +-- +-- Cabal already has an AST that it uses. Cartel could, perhaps, +-- have re-used these structures. Cartel does not do this for three +-- reasons. First, the Cabal API is a bit untidy, partially because +-- it has to do things that Cartel doesn't have to worry about, but +-- also because the comments in the Cabal modules themselves +-- indicate that the whole thing could use a refactoring. Second, +-- the Cabal developers make no commitment to keep that API stable. +-- Third, the Cartel API tries only to replicate format of the +-- plain-text Cabal file, which will be much more stable than the +-- Cabal API. +module Cartel.Ast where + +import qualified Data.Char as C +import qualified System.FilePath as P +import Data.Word +import System.FilePath +import Data.List (sortBy, intersperse) +import Data.Monoid +import qualified System.Directory as D +import Control.Monad.IO.Class +import Cartel.Types +import Cartel.Betsy + +-- * Basic types + +-- * Blank + +-- | Typeclass for things that can be blank. More specifically, +-- @blank a@ results in an item that, when rendered in a Cabal file, +-- is the null string. 'blank' can be useful to indicate that you +-- have no options, and you can also use it in combination with record +-- syntax when you want to specify just a few options. + +class Blank a where + blank :: a + +-- * Repositories + +-- | What kind of VCS repository is this? +data RepoKind + + = Head + -- ^ The latest development branch of the repository + + | This + -- ^ The sources for this release of this package. + deriving (Eq, Ord, Show) + +repoHead :: RepoKind +repoHead = Head + +repoThis :: RepoKind +repoThis = This + +-- | Version control systems. +data Vcs + = Darcs + | Git + | Svn + | Cvs NonEmptyString + -- ^ The argument 'String' is the named module + | Mercurial + | Bazaar + | ArchVcs + | Monotone + deriving (Eq, Ord, Show) + +darcs, git, svn, mercurial, bazaar, archVcs, monotone :: Vcs +cvs + :: NonEmptyString + -- ^ The named module + -> Vcs +darcs = Darcs +git = Git +svn = Svn +cvs = Cvs +mercurial = Mercurial +bazaar = Bazaar +archVcs = ArchVcs +monotone = Monotone + +-- | A single @repository@ section. +data Repository = Repository + { repoVcs :: Maybe Vcs + -- ^ What kind of 'Vcs' this is. This is required. + + , repoKind :: Maybe RepoKind + -- ^ The kind of repository ('repoHead' or 'repoThis'). Required. + + , repoTag :: String + -- ^ Repository tag. This is required for the 'repoThis' repository + -- kind and is optional for the 'repoHead' repository kind. + + , repoLocation :: NonEmptyString + -- ^ URL for the location of the repository--for example, for a + -- @darcs@ repo this might be @http:\/\/code.haskell.org\/foo\/@; for + -- git, this might be @git:\/\/github.com\/foo\/bar.git@. + + , repoBranch :: String + -- ^ The repository branch. + + , repoSubdir :: String + -- ^ The repository subdirectory. + } deriving (Eq, Ord, Show) + +instance Blank Repository where + blank = Repository Nothing Nothing "" "" "" "" + +-- | Creates a 'Section' that is a 'Repository' for a Github head. +-- For example, for Cartel, use @githubHead \"massysett\" \"cartel\"@. +githubHead + :: NonEmptyString + -- ^ The Github account name + -> NonEmptyString + -- ^ The Github project name within the account + -> Section +githubHead acct proj + = SecRepo $ blank { repoVcs = Just Git + , repoKind = Just Head + , repoLocation = loc + } + where + loc = "https://github.com/" ++ acct ++ "/" ++ proj ++ ".git" + +-- | Creates a 'Section' for a repository. +repository :: Repository -> Section +repository = SecRepo + +-- * Logicals + +-- | Condition; for use in a 'CondTree' and ultimately in a +-- 'CondBlock', which implements Cabal's @if-then-else@ feature. +data CondLeaf + = OS NonEmptyString + -- ^ Tests if the current operating system is the given name, + -- case-insensitive + | Arch NonEmptyString + -- ^ Tests if the current architecture is the given name, + -- case-insensitive + | Impl Compiler Constraint + -- ^ Tests for the configured Haskell implementation + | CFlag FlagName + -- ^ Evalutes to the current assignment of the flag of the given + -- name. To get a flag, use 'makeFlag'. + | CTrue + -- ^ Always True + | CFalse + -- ^ Always False + deriving (Eq, Ord, Show) + +-- | For use in a 'CondTree' or 'ConstrTree'. +data Logical + = Or + | And + deriving (Eq, Ord, Show) + +-- | Expresses a tree of constraints. This is how you represent +-- more complex dependency relationships. For example, to represent +-- @less than or equal to version 1.0@, use +-- +-- >> let one = Version [1,0] +-- >> in Branch Or (Leaf (Constraint LT one)) (Leaf (Constraint EQ one)) +data ConstrTree + = Leaf Ordering Version + | Branch Logical ConstrTree ConstrTree + deriving (Eq, Ord, Show) + + +-- | Expresses any version constraint, including no version +-- constraint. +data Constraint + = AnyVersion + | Constrained ConstrTree + deriving (Eq, Ord, Show) + +-- | Conditions. Ultimately these are used in a 'CondBlock'. +data Condition + = CLeaf CondLeaf + | CBranch Logical Condition Condition + | CNegate Condition + deriving (Eq, Ord, Show) + +-- | Like 'not', which is what I would have named it but for the +-- conflict. Only 'Condition's have this sort of operation; Cabal +-- does not have a (documented, at least) way to express this for +-- package constraints. +invert :: Condition -> Condition +invert = CNegate + +-- | Conditional blocks. These implement the @if-then-else@ feature +-- of Cabal files. You must have at least one thing to do if the +-- condition is True; the if-false block is optional. +data CondBlock a = CondBlock + { condIf :: Condition + -- ^ If this condition is true . . . + , ifTrue :: (a, [a]) + -- ^ . . . then do this . . . + , ifFalse :: [a] + -- ^ . . . or if it's false, do this instead. + } deriving (Eq, Ord, Show) + +instance Functor CondBlock where + fmap f (CondBlock i (t1, ts) flse) + = CondBlock i (f t1, fmap f ts) (fmap f flse) + +class LogicTree a where + (&&&) :: a -> a -> a + (|||) :: a -> a -> a + +instance LogicTree Constraint where + AnyVersion &&& x = x + Constrained x &&& AnyVersion = Constrained x + Constrained x &&& Constrained y = Constrained (x &&& y) + + AnyVersion ||| _ = AnyVersion + Constrained _ ||| AnyVersion = AnyVersion + Constrained x ||| Constrained y = Constrained (x ||| y) + +instance LogicTree ConstrTree where + l &&& r = Branch And l r + l ||| r = Branch Or l r + +instance LogicTree Condition where + l &&& r = CBranch And l r + l ||| r = CBranch Or l r + +infixr 3 &&& +infixr 2 ||| + +-- | Less than +lt :: Version -> Constraint +lt = Constrained . Leaf LT + +-- | Greater than +gt :: Version -> Constraint +gt = Constrained . Leaf GT + +-- | Equal to +eq :: Version -> Constraint +eq = Constrained . Leaf EQ + +-- | Less than or equal to +ltEq :: Version -> Constraint +ltEq v = lt v ||| eq v + +-- | Greater than or equal to +gtEq :: Version -> Constraint +gtEq v = gt v ||| eq v + +-- | Matches any version at all (in a Cabal file, this is represented +-- as an empty string). +anyVersion :: Constraint +anyVersion = AnyVersion + + +-- | Creates a package interval that is closed on the left, open on +-- the right. Useful for the common case under the PVP to specify +-- that you depend on a version that is at least a particular +-- version, but less than another version. +-- +-- > closedOpen "bytestring" [0,17] [0,19] ==> bytestring >= 0.17 && < 0.19 + +closedOpen + :: NonEmptyString + -- ^ Package name + -> Version + -- ^ Version number for lower bound + -> Version + -- ^ Version number for upper bound + -> Package + -- ^ Resulting 'Package' +closedOpen n l u = Package n (gtEq l &&& lt u) + +-- | Specifies a particular API version. Useful to lock your +-- package dependencies down to a particular API version. +-- +-- > apiVersion "base" [1] ==> base >= 1 && < 2 +-- > apiVersion "base" [1,2] ==> base >= 1.2 && < 1.3 +-- > apiVersion "base" [1,2,3] ==> base >= 1.2.3 && < 1.2.4 + +apiVersion :: NonEmptyString -> Version -> Package +apiVersion n v = closedOpen n v u + where + u = case v of + [] -> error "apiVersion: requires a non-empty list argument" + _ -> init v ++ [succ (last v)] + +-- | Depends on the version given, up to the next breaking API +-- change. +-- +-- > nextBreaking "base" [4] ==> base >= 4 && < 4.1 +-- > nextBreaking "base" [4,1] ==> base >= 4.1 && < 4.2 +-- > nextBreaking "base" [4,7,0,0] ==> base >= 4.7.0.0 && < 4.8 + +nextBreaking + :: NonEmptyString + -> Version + -> Package +nextBreaking n v = closedOpen n v u + where + u = case v of + [] -> error "nextBreaking: requires a non-empty list argument" + x:[] -> [x, 1] + x:y:_ -> x : succ y : [] + +-- | Depends on the version given, up to the next time the first +-- digit increments. Useful for @base@. +-- +-- > nextBreaking "base" [4] ==> base >= 4 && < 5 + +nextMajor + :: NonEmptyString + -> Version + -> Package +nextMajor n v = closedOpen n v u + where + u = case v of + [] -> error "nextMajor: requires a non-empty list argument" + x:_ -> succ x : [] + +-- | Depends on exactly this version only. +-- +-- > exactly "base" [4,5,0,0] ==> base ==4.5.0.0 + +exactly :: NonEmptyString -> Version -> Package +exactly n v = Package n (eq v) + +-- | Allows any version of a package. + +unconstrained + :: NonEmptyString + -- ^ Name of package + -> Package +unconstrained nm = Package nm anyVersion + +-- | Builds @if@ statements. For example: +-- +-- > condition (flag "buildExe") (buildable True, []) [buildable False] +-- +-- A little more complicated: +-- +-- > condition (flag "buildExe" &&& system "windows") +-- > (buildable True, []) [buildable False] +condBlock + :: HasBuildInfo a + => Condition + -- ^ Condition to satisfy + -> (a, [a]) + -- ^ Use these results if condition is true + -> [a] + -- ^ Use these results if condition if false + -> a +condBlock tree ifT ifF = + conditional $ CondBlock tree ifT ifF + +-- | Operating system; tested against @System.Info.os@ on the +-- target system. +system :: NonEmptyString -> Condition +system = CLeaf . OS + +-- | Argument is matched against @System.Info.arch@ on the target +-- system. +arch :: NonEmptyString -> Condition +arch = CLeaf . Arch + +-- | Tests for the configured Haskell implementation. +impl :: Compiler -> Constraint -> Condition +impl cm cn = CLeaf $ Impl cm cn + +-- | Evaluates to the current assignment of the flag of the given +-- name. Flag names are case insensitive. Testing for flags that +-- have not been introduced with a flag section is an error. +flag :: FlagName -> Condition +flag = CLeaf . CFlag + +-- | Always true. +true :: Condition +true = CLeaf CTrue + +-- | Always false. +false :: Condition +false = CLeaf CFalse + +-- * Versions + +-- | A version number. The Cabal documentation says this +-- \"usually\" consists of a sequence of natural numbers separated +-- by dots. Though this suggests that a version number could +-- contain something other than natural numbers, in fact the types +-- in the Cabal library do not allow anything other than numbers and +-- you will get a parse error if you try to use anything else. +-- +-- Therefore Cartel's 'Version' type only allows a list of 'Word', as +-- each number cannot be negative. In addition, this list should +-- never be empty. However, this is just a type synonym for a list of +-- 'Word', so the type system does not enforce the requirement that +-- this list be non-empty. +type Version = [Word] + +-- * Packages + +-- | A single package, consisting of a package name and an optional +-- set of constraints. Used when specifying 'buildDepends', +-- 'buildTools', and 'pkgConfigDepends'. +-- +-- Some functions exist to ease the creation of a 'Package'. For a +-- package with no version constrains, simply do something like +-- @'unconstrained' \"QuickCheck\"@. Common use cases are +-- covered in the functions in the \"Package Helpers\" section below. +-- For something more complicated, use the functions in the +-- \"Logicals\" sections above, along with the '&&&' and '|||' +-- combinators, to create your own 'Constraint' and then use it with +-- the 'package' function. + +data Package = Package NonEmptyString Constraint + deriving (Eq, Ord, Show) + +-- | Builds a 'Package'. +package + :: NonEmptyString + -- ^ The name of the package + -> Constraint + -- ^ Version constraints. + -> Package +package = Package + +-- * Build information + +-- | Default language. Currently not documented, see +-- +-- +data DefaultLanguage + = Haskell98 + | Haskell2010 + deriving (Eq, Ord, Show) + +-- | Sets Haskell 98 as the @default-language@. +-- +-- Currently not documented in Cabal, see +-- +-- +haskell98 :: HasBuildInfo a => a +haskell98 = buildInfo $ DefaultLanguage Haskell98 + +-- | Sets Haskell 2010 as the @default-language@. +-- +-- Currently not documented in Cabal, see +-- +-- +haskell2010 :: HasBuildInfo a => a +haskell2010 = buildInfo $ DefaultLanguage Haskell2010 + +-- | A single field of build information. This can appear in a +-- @Library@, 'Executable', 'TestSuite', or 'Benchmark'. +data BuildInfoField + = BuildDepends [Package] + -- ^ A list of packages needed to build this component + + | OtherModules [NonEmptyString] + -- ^ Modules used but not exposed. For libraries, these are + -- hidden modules; for executable, these are auxiliary modules to + -- be linked with the file in the @main-is@ field. + -- + -- 'Cartel.Tools.modules' can help greatly with maintenance of + -- this field. + + | HsSourceDirs [NonEmptyString] + -- ^ Root directories for the module hierarchy + + | Extensions [NonEmptyString] + -- ^ Haskell extensions used by every module. + + | BuildTools [Package] + -- ^ Programs needed to build this package, such as c2hs. + + | Buildable Bool + -- ^ Is this component buildable? + + | GHCOptions [NonEmptyString] + | GHCProfOptions [NonEmptyString] + | GHCSharedOptions [NonEmptyString] + | HugsOptions [NonEmptyString] + | Nhc98Options [NonEmptyString] + | Includes [NonEmptyString] + -- ^ Header files to be included in any compilations via C. + -- Applies to both header files that are already installed on the + -- system and to those coming with the package to be installed. + + | InstallIncludes [NonEmptyString] + -- ^ Header files to be installed into @$libdir/includes@ when the + -- package is installed. These files should be found in relative + -- to the top of the source tree or relative to one of the + -- directories listed in @include-dirs@. + + | IncludeDirs [NonEmptyString] + -- ^ List of diretories to search for header files when dealing + -- with C compilations. + + | CSources [NonEmptyString] + -- ^ C sources to be compiled and lined with the Haskell files. + + | ExtraLibraries [NonEmptyString] + -- ^ Extra libraries to link with. + + | ExtraLibDirs [NonEmptyString] + -- ^ Directories to search for libraries. + + | CCOptions [NonEmptyString] + -- ^ C Compiler options. + + | CPPOptions [NonEmptyString] + -- ^ C Preprocessor options. Undocumented, see + -- + + | LDOptions [NonEmptyString] + -- ^ Linker options. + + | PkgConfigDepends [Package] + -- ^ List of pkg-config packages needed to build this component. + + | Frameworks [NonEmptyString] + -- ^ OS X frameworks. + + | DefaultLanguage DefaultLanguage + + deriving (Eq, Ord, Show) + +-- * Libraries + +-- | A field in the @Library@ section of the Cabal file. A +-- @Library@ section can have multiple fields. +data LibraryField + = ExposedModules [NonEmptyString] + -- ^ Exposed modules. 'modules' can help you generate this, without + -- you having to manually list each module and keep the list up to + -- date. + + | Exposed Bool + -- ^ Is the library exposed? GHC can hide libraries. + + | LibConditional (CondBlock LibraryField) + -- ^ The @Library@ section can contain conditional blocks. + + | LibInfo BuildInfoField + -- ^ The @Library@ section can contain build information. + + deriving (Eq, Ord, Show) + +-- | Whether a library is exposed. GHC can hide libraries. +exposed :: Bool -> LibraryField +exposed = Exposed + +-- | A library's exposed modules. 'modules' can help you generate +-- this, without you having to manually list each module and keep the +-- list up to date. +exposedModules :: [NonEmptyString] -> LibraryField +exposedModules = ExposedModules + +-- * Executables + +-- | A single field in an 'Executable' section. An 'Executable' +-- section may have multiple fields. +data ExecutableField + = ExeConditional (CondBlock ExecutableField) + -- ^ An 'Executable' section can contain conditional blocks. + + | ExeInfo BuildInfoField + -- ^ An 'Executable' section can contain one or more build + -- information fields. + + | ExeMainIs NonEmptyString + -- ^ The name of the @.hs@ or @.lhs@ file containing the @Main@ + -- module. Note that it is the @.hs@ filename that must be listed, + -- even if that file is generated using a preprocessor. The source + -- file must be relative to one of the directories listed in + -- 'hsSourceDirs'. + + deriving (Eq, Ord, Show) + +-- | An entire @Executable@ section. +data Executable = Executable + { exeName :: NonEmptyString + -- ^ The name of the executable that Cabal will build. + , exeFields :: [ExecutableField] + -- ^ An executable can contain zero or more 'ExecutableField's. + } deriving (Eq, Ord, Show) + +-- | Builds a 'Section' for executable files. +executable + :: NonEmptyString + -- ^ The name of the executable that Cabal will build. + -> [ExecutableField] + -- ^ An executable can contain zero or more 'ExecutableField's. + -> Section +executable nm fs = SecExe (Executable nm fs) + +-- * Test suites + +-- | What kind of test suite is this? +data TestSuiteType + = ExitcodeStdio + -- ^ An @exitcode-stdio-1.0@ test. The @String@ is the name of + -- the file containing the executable code. In this case, the + -- @test-main-is@ field is required. + + | Detailed + -- ^ The @detailed-0.9@ test. In this case, the @test-module@ + -- field is required. + deriving (Eq, Ord, Show) + +detailed :: TestSuiteField +detailed = TestSuiteType Detailed + +-- | A single field value in a 'TestSuite' section. A single test +-- suite section may contain mulitple fields. +data TestSuiteField + = TestConditional (CondBlock TestSuiteField) + -- ^ The 'TestSuite' may contain zero or more conditional blocks. + | TestInfo BuildInfoField + -- ^ The 'TestSuite' may contain zero or more build information + -- fields. + | TestMainIs NonEmptyString + -- ^ The name of the @.hs@ or @.lhs@ file containing the @Main@ + -- module. Note that it is the @.hs@ filename that must be listed, + -- even if that file is generated using a preprocessor. The source + -- file must be relative to one of the directories listed in + -- 'hsSourceDirs'. + -- + -- This is required when using 'ExitcodeStdio' and disallowed when + -- using 'Detailed'. + + | TestSuiteType TestSuiteType + | TestModule NonEmptyString + -- ^ The module exporting the @tests@ symbol. This is required when + -- using 'Detailed' and disallowed when using 'ExitcodeStdio'. + + deriving (Eq, Ord, Show) + +-- | The module exporting the @tests@ symbol. This is required when +-- using 'Detailed' and disallowed when using 'ExitcodeStdio'. +testModule :: NonEmptyString -> TestSuiteField +testModule = TestModule + +-- | An entire @test-suite@ section. +data TestSuite = TestSuite + { testSuiteName :: NonEmptyString + -- ^ The executable name for the resulting test suite + , testSuiteFields :: [TestSuiteField] + -- ^ Zero or more 'TestSuiteField's. + } deriving (Eq, Ord, Show) + +-- | Builds a 'Section' for test suites. +testSuite + :: NonEmptyString + -- ^ The executable name for the resulting test suite + -> [TestSuiteField] + -- ^ Zero or more 'TestSuiteField's. + -> Section +testSuite nm fs = SecTest (TestSuite nm fs) + +-- * Benchmarks + +data BenchmarkType + = BenchExitCode + -- ^ @exitcode-stdio-1.0@, currently the only supported benchmark interface. + deriving (Eq, Ord, Show) + +-- | A single field in a @Benchmark@ section. +data BenchmarkField + = BenchmarkConditional (CondBlock BenchmarkField) + | BenchmarkInfo BuildInfoField + | BenchmarkType BenchmarkType + | BenchmarkMainIs NonEmptyString + -- ^ The name of the @.hs@ or @.lhs@ file containing the @Main@ + -- module. Note that it is the @.hs@ filename that must be listed, + -- even if that file is generated using a preprocessor. The source + -- file must be relative to one of the directories listed in + -- 'hsSourceDirs'. + deriving (Eq, Ord, Show) + +-- | An entire @Benchmark@ section. +data Benchmark = Benchmark + { benchmarkName :: NonEmptyString + -- ^ The name of the executable file that will be the benchmark + , benchmarkFields :: [BenchmarkField] + -- ^ Zero or more benchmark fields. + } deriving (Eq, Ord, Show) + +-- | Builds a 'Section' for benchmarks. +benchmark + :: NonEmptyString + -- ^ The name of the executable file that will be the benchmark + -> [BenchmarkField] + -- ^ Zero or more benchmark fields. + -> Section +benchmark nm fs = SecBench (Benchmark nm fs) + +-- * Overloaded fields + +-- | Things that can be an item in a build information field in a +-- Cabal file. +class HasBuildInfo a where + + -- | Takes a conditional block and wraps it in the field type. + conditional :: CondBlock a -> a + + -- | Takes a build information field and wraps it in the field + -- type. + buildInfo :: BuildInfoField -> a + +instance HasBuildInfo LibraryField where + conditional = LibConditional + buildInfo = LibInfo + +instance HasBuildInfo ExecutableField where + conditional = ExeConditional + buildInfo = ExeInfo + +instance HasBuildInfo TestSuiteField where + conditional = TestConditional + buildInfo = TestInfo + +instance HasBuildInfo BenchmarkField where + conditional = BenchmarkConditional + buildInfo = BenchmarkInfo + +-- # Build info helpers + +-- ^ A list of packages needed to build this component +buildDepends :: HasBuildInfo a => [Package] -> a +buildDepends = buildInfo . BuildDepends + +-- ^ Modules used but not exposed. For libraries, these are +-- hidden modules; for executable, these are auxiliary modules to +-- be linked with the file in the @main-is@ field. +-- +-- 'modules' can help greatly with maintenance of +-- this field. + +otherModules :: HasBuildInfo a => [NonEmptyString] -> a +otherModules = buildInfo . OtherModules + +-- ^ Root directories for the module hierarchy +hsSourceDirs :: HasBuildInfo a => [NonEmptyString] -> a +hsSourceDirs = buildInfo . HsSourceDirs + +-- ^ Haskell extensions used by every module. +extensions :: HasBuildInfo a => [NonEmptyString] -> a +extensions = buildInfo . Extensions + +-- | Programs needed to build this package, such as c2hs. +buildTools :: HasBuildInfo a => [Package] -> a +buildTools = buildInfo . BuildTools + +-- | Is this component buildable? +buildable :: HasBuildInfo a => Bool -> a +buildable = buildInfo . Buildable + +ghcOptions :: HasBuildInfo a => [NonEmptyString] -> a +ghcOptions = buildInfo . GHCOptions + +ghcProfOptions :: HasBuildInfo a => [NonEmptyString] -> a +ghcProfOptions = buildInfo . GHCProfOptions + +ghcSharedOptions :: HasBuildInfo a => [NonEmptyString] -> a +ghcSharedOptions = buildInfo . GHCSharedOptions + +hugsOptions :: HasBuildInfo a => [NonEmptyString] -> a +hugsOptions = buildInfo . HugsOptions + +nhc98Options :: HasBuildInfo a => [NonEmptyString] -> a +nhc98Options = buildInfo . Nhc98Options + +-- | Header files to be included in any compilations via C. +-- Applies to both header files that are already installed on the +-- system and to those coming with the package to be installed. + +includes :: HasBuildInfo a => [NonEmptyString] -> a +includes = buildInfo . Includes + +-- | Header files to be installed into @$libdir/includes@ when the +-- package is installed. These files should be found in relative +-- to the top of the source tree or relative to one of the +-- directories listed in @include-dirs@. +installIncludes :: HasBuildInfo a => [NonEmptyString] -> a +installIncludes = buildInfo . InstallIncludes + +-- | List of diretories to search for header files when dealing +-- with C compilations. +includeDirs :: HasBuildInfo a => [NonEmptyString] -> a +includeDirs = buildInfo . IncludeDirs + +-- | C sources to be compiled and lined with the Haskell files. +cSources :: HasBuildInfo a => [NonEmptyString] -> a +cSources = buildInfo . CSources + +-- | Extra libraries to link with. +extraLibraries :: HasBuildInfo a => [NonEmptyString] -> a +extraLibraries = buildInfo . ExtraLibraries + +-- | Directories to search for libraries. +extraLibDirs :: HasBuildInfo a => [NonEmptyString] -> a +extraLibDirs = buildInfo . ExtraLibDirs + +-- | C Compiler options. +ccOptions :: HasBuildInfo a => [NonEmptyString] -> a +ccOptions = buildInfo . CCOptions + +-- | C Preprocessor options. Undocumented, see +-- +cppOptions :: HasBuildInfo a => [NonEmptyString] -> a +cppOptions = buildInfo . CPPOptions + +-- | Linker options. +ldOptions :: HasBuildInfo a => [NonEmptyString] -> a +ldOptions = buildInfo . LDOptions + +-- | List of pkg-config packages needed to build this component. +pkgConfigDepends :: HasBuildInfo a => [Package] -> a +pkgConfigDepends = buildInfo . PkgConfigDepends + +-- | OS X frameworks. +frameworks :: HasBuildInfo a => [NonEmptyString] -> a +frameworks = buildInfo . Frameworks + +-- | Sections that build executables. These are the 'Executable', +-- 'Benchmark', and 'TestSuite' sections. +class BuildsExe a where + mainIs :: NonEmptyString -> a + -- ^ Overloaded function allowing you to use 'mainIs' for an + -- 'Executable', 'Benchmark', or 'TestSuite' section. + +instance BuildsExe ExecutableField where + mainIs = ExeMainIs + +instance BuildsExe TestSuiteField where + mainIs = TestMainIs + +instance BuildsExe BenchmarkField where + mainIs = BenchmarkMainIs + +-- | Sections that build executables that can be @exitcode-stdio-1.0@. +-- These are the 'Benchmark' and 'TestSuite' sections. +class BuildsExitcode a where + exitcodeStdio :: a + -- ^ Returns a field that is @exitcode-stdio-1.0@ + +instance BuildsExitcode TestSuiteField where + exitcodeStdio = TestSuiteType ExitcodeStdio + +instance BuildsExitcode BenchmarkField where + exitcodeStdio = BenchmarkType BenchExitCode + +-- | Builds two fields. The first indicates that this is an +-- @exitcode-stdio-1.0@ executable; the second is the appropriate +-- @main-is@ field. +exitcodeFields + :: (BuildsExitcode a, BuildsExe a) + => NonEmptyString + -- ^ Value for @main-is@ field + -> [a] +exitcodeFields m = [exitcodeStdio, mainIs m] + +-- * Getting module lists + +-- | Gets all Haskell modules in a given directory tree. Allows you +-- to specify what extensions you are interested in. For this to work +-- best, you will want to keep all your library modules in their own +-- directory, such as @lib/@. You can also separate executables and +-- test suites this way. 'hsSourceDirs' will then tell Cabal to use +-- these directories. + +modulesWithExtensions + :: MonadIO m + => [NonEmptyString] + -- ^ Look for files that have these extensions. 'fileExtensions' + -- covers the most common cases. Files without one of these + -- extensions are ignored. Files and directories that do not begin + -- with an uppercase letter are ignored. (This also ignores files + -- that start with a dot.) Directories with a dot anywhere in the + -- name are ignored. + -- + -- Do not include the leading dot with the extension. For example, + -- to look for Haskell and literate Haskell files only, use + -- + -- > ["hs", "lhs"] + + -> FilePath + -- ^ Start searching within this directory. + + -> Betsy m [NonEmptyString] + -- ^ A list of Haskell modules in the given directory tree. The + -- file contents are not examined; only the file names matter. + -- Returned as a list of dotted names. + +modulesWithExtensions exts fp + = liftIO $ modulesWithExtensionsIO exts fp + + +-- | Same as +-- +-- @ +-- 'modulesWithExtensions' 'fileExtensions' +-- @ +modules + :: MonadIO m + => FilePath + -> Betsy m [NonEmptyString] +modules = modulesWithExtensions fileExtensions + +-- | Common extensions of Haskell files and files that are +-- preprocessed into Haskell files. Includes: +-- +-- * hs (Haskell) +-- +-- * lhs (literate Haskell) +-- +-- * gc (greencard) +-- +-- * chs (c2hs) +-- +-- * hsc (hsc2hs) +-- +-- * y and ly (happy) +-- +-- * x (alex) +-- +-- * cpphs + +fileExtensions :: [String] +fileExtensions = + [ "hs" + , "lhs" + , "gc" + , "chs" + , "hsc" + , "y" + , "ly" + , "x" + , "cpphs" + ] + +interestingFile + :: [String] + -- ^ Extensions of module files + -> FilePath + -> Bool + +interestingFile xs s = case s of + "" -> False + x:_ + | not (C.isUpper x) -> False + | otherwise -> let mayExt = P.takeExtension s + in case mayExt of + [] -> False + _ : ext -> ext `elem` xs + +interestingDir :: FilePath -> Bool +interestingDir p = case p of + [] -> False + x:_ + | not (C.isUpper x) -> False + | otherwise -> not $ '.' `elem` p + +-- | Gets all Haskell modules in a given directory tree. Only files +-- with one of the extensions listed in 'fileExtensions' are +-- returned. Files and directories that do not begin with an +-- uppercase letter are ignored. (This also ignores files that +-- start with a dot.) Directories with a dot anywhere in the name +-- are ignored. + +modulesIO + :: FilePath + -- ^ Start searching within this directory. + -> IO [String] + -- ^ A list of Haskell modules in the given directory tree. The + -- file contents are not examined; only the file names matter. + -- Returned as a list of dotted names. +modulesIO = modulesWithExtensionsIO fileExtensions + + +-- | Gets all Haskell modules in a given directory tree. Allows you +-- to specify what extensions you are interested in. + +modulesWithExtensionsIO + :: [String] + -- ^ Look for files that have one of these extensions. + -- 'fileExtensions' covers the most common cases. Files without + -- one of these extensions are ignored. Files and directories + -- that do not begin with an uppercase letter are ignored. (This + -- also ignores files that start with a dot.) Directories with a + -- dot anywhere in the name are ignored. + -- + -- Do not include the leading dot with the extension. For + -- example, to look for Haskell and literate Haskell files only, use + -- + -- > ["hs", "lhs"] + + -> FilePath + -- ^ Start searching within this directory. + + -> IO [String] + -- ^ A list of Haskell modules in the given directory tree. The + -- file contents are not examined; only the file names matter. + -- Returned as a list of dotted names. + +modulesWithExtensionsIO exts start + = fmap (map modName . sortBy sorter . map reverse) + $ modulesInDir exts start [] + where + modName = concat . intersperse "." + +sorter :: [String] -> [String] -> Ordering +sorter x y = mconcat (zipWith compare x y) <> compare lenX lenY + where + (lenX, lenY) = (length x, length y) + +modulesInDir + :: [String] + -- ^ Extensions of module files + -> FilePath + -- Search is rooted in this directory + -> [FilePath] + -- ^ Stack of directories we're in + -> IO [[String]] + -- ^ Returns a list of modules in this directory. +modulesInDir exts start dirs = do + cs <- D.getDirectoryContents (start P.joinPath (reverse dirs)) + fmap concat . mapM (processFile exts start dirs) $ cs + +processFile + :: [String] + -- ^ Extensions of module files + -> FilePath + -- ^ Search is rooted in this directory + -> [FilePath] + -- Stack of directories we're in, including current directory + -> FilePath + -- ^ Interesting file under investigation + -> IO [[String]] +processFile exts start dirs this = do + isDir <- D.doesDirectoryExist + (start (P.joinPath . reverse $ this : dirs)) + if isDir + then if interestingDir this + then modulesInDir exts start (this : dirs) + else return [] + else return $ if interestingFile exts this + then [(P.dropExtension this : dirs)] + else [] + +-- * Section + +-- | A single section in a Cabal file; this may be a source +-- repository, executable, test suite, or benchmark. You build a +-- 'Section' with the 'repository', 'executable', 'testSuite', and +-- 'benchmark' functions. +data Section + = SecRepo Repository + | SecExe Executable + | SecTest TestSuite + | SecBench Benchmark + deriving (Eq, Ord, Show) + +-- * Properties + +data BuildType + = Simple + | Configure + | Make + | Custom + deriving (Eq, Ord, Show) + +simple, configure, make, custom :: BuildType +simple = Simple +configure = Configure +make = Make +custom = Custom + +data License + = GPL + | AGPL + | LGPL + | BSD2 + | BSD3 + | BSD4 + | MIT + | MPL + | Apache + | PublicDomain + | AllRightsReserved + | OtherLicense + deriving (Eq, Ord, Show) + +gpl, agpl, lgpl, bsd2, bsd3, bsd4, mit, mpl, apache, publicDomain, + allRightsReserved, otherLicense :: License + +gpl = GPL +agpl = AGPL +lgpl = LGPL +bsd2 = BSD2 +bsd3 = BSD3 +bsd4 = BSD4 +mit = MIT +mpl = MPL +apache = Apache +publicDomain = PublicDomain +allRightsReserved = AllRightsReserved +otherLicense = OtherLicense + +data Compiler + = GHC + | NHC + | YHC + | Hugs + | Helium + | JHC + | LHC + deriving (Eq, Ord, Show) + +ghc, nhc, yhc, hugs, helium, jhc, lhc :: Compiler +ghc = GHC +nhc = NHC +yhc = YHC +hugs = Hugs +helium = Helium +jhc = JHC +lhc = LHC + +-- | Global package properties. +data Properties = Properties + { name :: String + , version :: Version + , cabalVersion :: Maybe (Word, Word) + , buildType :: Maybe BuildType + , license :: Maybe License + , licenseFile :: String + , licenseFiles :: [NonEmptyString] + , copyright :: String + , author :: String + , maintainer :: String + , stability :: String + , homepage :: String + , bugReports :: String + , packageUrl :: String + , synopsis :: String + , description :: [String] + , category :: String + -- ^ According to the \"Developing Cabal Packages\" document, this + -- should simply be an email address. + , testedWith :: [(Compiler, Constraint)] + , dataFiles :: [NonEmptyString] + , dataDir :: String + , extraSourceFiles :: [NonEmptyString] + , extraDocFiles :: [NonEmptyString] + , extraTmpFiles :: [NonEmptyString] + } deriving (Eq, Ord, Show) + +instance Blank Properties where + blank = Properties + { name = "" + , version = [] + , cabalVersion = Nothing + , buildType = Nothing + , license = Nothing + , licenseFile = "" + , licenseFiles = [] + , copyright = "" + , author = "" + , maintainer = "" + , stability = "" + , homepage = "" + , bugReports = "" + , packageUrl = "" + , synopsis = "" + , description = [] + , category = "" + , testedWith = [] + , dataFiles = [] + , dataDir = "" + , extraSourceFiles = [] + , extraDocFiles = [] + , extraTmpFiles = [] + } + +-- * Cabal + +-- | Represents an entire Cabal file. +data Cabal = Cabal + { properties :: Properties + , library :: [LibraryField] + , sections :: [Section] + } deriving (Eq, Ord, Show) + +-- | Creates a 'Cabal' value when applied to package properties, any +-- applicable library fields, and any sections. +cabal :: Properties -> [LibraryField] -> [Section] -> Cabal +cabal = Cabal + +instance Blank Cabal where + blank = Cabal blank [] [] diff --git a/lib/Cartel/Betsy.hs b/lib/Cartel/Betsy.hs new file mode 100644 --- /dev/null +++ b/lib/Cartel/Betsy.hs @@ -0,0 +1,15 @@ +-- | Public interface for 'Betsy', the Cartel flag maker. Simply +-- re-exports safe bindings from "Cartel.Betsy.Internal". +module Cartel.Betsy + ( FlagName + , flagNameHead + , flagNameTail + , FlagOpts(..) + , Betsy + , Error(..) + , runBetsy + , makeFlag + , currentFlags + ) where + +import Cartel.Betsy.Internal diff --git a/lib/Cartel/Betsy/Internal.hs b/lib/Cartel/Betsy/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Cartel/Betsy/Internal.hs @@ -0,0 +1,132 @@ +-- | Internal workings of 'Betsy', the Cartel flag maker. Use of this +-- module may break 'Betsy' invariants. +module Cartel.Betsy.Internal where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Cartel.Types +import Control.Applicative + +-- | Errors that may result from running a 'Betsy' computation. +data Error + = DuplicateFlag FlagName + -- ^ The user requested creation of a duplicate flag. + | Failed String + -- ^ 'fail' was invoked. + | EmptyFlagName + -- ^ The user requested creation of a flag with an empty name. + deriving (Eq, Ord, Show) + +renderError :: Error -> String +renderError e = unlines $ + "Error while attempting to generate Cabal file from Cartel source." + : case e of + DuplicateFlag (FlagName c cs) -> + ["Duplicated flag: " ++ (c:cs)] + Failed s -> ["The \"fail\" function was invoked: " ++ s] + EmptyFlagName -> ["Empty flag name"] + +-- | Internal state maintained in the 'Betsy' type. +data State = State [(FlagName, FlagOpts)] + deriving (Eq, Ord, Show) + +-- | Computations that can create and use Cabal flags. Use of this +-- type, along with the 'Cartel.defaultMain' function ensures that any +-- 'FlagName' you use has been properly set up by using 'makeFlag'. +-- That way, you don't use flags in a 'Cartel.flag' without actually +-- declaring the flag. When 'Cartel.defaultMain' creates your Cabal +-- file, it will print the necessary @Flag@ sections. +-- +-- 'Betsy' is parameterized on a type, @m@. When this type is a +-- monad, 'Betsy' is also a monad, allowing you to use use the usual +-- monad combinators and @do@ notation. 'Betsy' is also a monad transformer. + +newtype Betsy m a = Betsy (State -> m (Either Error (a, State))) + +instance Monad m => Monad (Betsy m) where + return a = Betsy $ \s -> return (Right (a, s)) + (Betsy l) >>= f = Betsy $ \s -> do + ei <- l s + case ei of + Left e -> return (Left e) + Right (g, s') -> do + let Betsy r = f g + r s' + fail s = Betsy $ \_ -> return (Left (Failed s)) + +instance Functor m => Functor (Betsy m) where + fmap f (Betsy k) = Betsy $ fmap (fmap f') k + where + f' ei = fmap (\(a, s) -> (f a, s)) ei + +instance (Monad m, Functor m) => Applicative (Betsy m) where + pure = return + (<*>) = ap + +instance MonadTrans Betsy where + lift k = Betsy $ \st -> do + a <- k + return $ Right (a, st) + +instance MonadIO m => MonadIO (Betsy m) where + liftIO = lift . liftIO + +-- ** Flags + +-- | Options for flags, except for the flag's name. +data FlagOpts = FlagOpts + { flagDescription :: String + -- ^ A one-line description of what the flag does; this is optional. + , flagDefault :: Bool + -- ^ Is this flag on or off by default? + , flagManual :: Bool + -- ^ If a flag is manual, Cabal will not change its value. If a + -- flag is not manual, Cabal will change its value automatically to + -- attempt to satisfy the package's dependencies. + } deriving (Eq, Ord, Show) + +-- | The name of a flag. Only 'makeFlag' creates flags; it will +-- return a 'FlagName' to you. You can then use that 'FlagName' in a +-- conditional using 'Cartel.flag'. +data FlagName = FlagName + { flagNameHead :: Char + , flagNameTail :: String + } deriving (Eq, Ord, Show) + +-- | Creates new flags. +makeFlag + :: Applicative m + => NonEmptyString + -- ^ Name of flag + -> FlagOpts + -- ^ Options for the flag + -> Betsy m FlagName + -- ^ This operation will fail if there is already a flag with the + -- name you gave. +makeFlag nes opts = Betsy $ \(State fls) -> pure $ + case nes of + [] -> Left EmptyFlagName + x:xs -> + let nm = FlagName x xs + in case lookup nm fls of + Nothing -> + let st' = State ((nm, opts) : fls) + in Right (nm, st') + Just _ -> Left (DuplicateFlag nm) + +runBetsy + :: Functor m + => Betsy m a + -> m (Either Error (a, [(FlagName, FlagOpts)])) + -- ^ Returns 'Left' if the making of a flag failed. Otherwise, + -- returns the result of the computation, along with a list of all + -- flags made. +runBetsy (Betsy f) = fmap (fmap g) $ f (State []) + where + g (a, State ls) = (a, ls) + + +-- | Returns a list of all flags made so far. +currentFlags :: Applicative f => Betsy f [(FlagName, FlagOpts)] +currentFlags = Betsy $ \(State ls) -> pure (Right (ls, State ls)) diff --git a/lib/Cartel/Empty.hs b/lib/Cartel/Empty.hs deleted file mode 100644 --- a/lib/Cartel/Empty.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | Default values for the data types in "Cartel.Ast". These --- defaults are genrally filled in with blank values. Use these --- default values where you can; by doing so you help future-proof --- your code. Use the empty value as a starting point and fill in --- the components of the record that you need. -module Cartel.Empty where - -import qualified Cartel.Ast as A - -class Empty a where - empty :: a - --- | A default 'A.Properties'. 'A.prCabalVersion' is @(1, 14)@ to --- specify Cabal version 1.14; 'A.prBuildType' is 'A.Simple', and --- 'A.prLicense' is 'A.BSD3'. All other items are either the empty --- 'String' or the empty list, including the 'A.prVersion', which is --- left empty. -instance Empty A.Properties where - empty = A.Properties - { A.prName = "" - , A.prVersion = A.Version [] - , A.prCabalVersion = (1, 14) - , A.prBuildType = A.Simple - , A.prLicense = A.BSD3 - , A.prLicenseFile = "" - , A.prLicenseFiles = [] - , A.prCopyright = "" - , A.prAuthor = "" - , A.prMaintainer = "" - , A.prStability = "" - , A.prHomepage = "" - , A.prBugReports = "" - , A.prPackageUrl = "" - , A.prSynopsis = "" - , A.prDescription = [] - , A.prCategory = "" - , A.prTestedWith = [] - , A.prDataFiles = [] - , A.prDataDir = "" - , A.prExtraSourceFiles = [] - , A.prExtraDocFiles = [] - , A.prExtraTmpFiles = [] - } - --- | A default 'A.Cabal'. 'empty' is used for 'A.cProperties', --- and 'A.cLibrary' is 'Nothing'; all other lists are empty. -instance Empty A.Cabal where - empty = A.Cabal - { A.cProperties = empty - , A.cRepositories = [] - , A.cFlags = [] - , A.cLibrary = Nothing - , A.cExecutables = [] - , A.cTestSuites = [] - , A.cBenchmarks = [] - } - --- | A default 'A.Repository'. The VCS type is 'A.Git' and the --- repository kind is 'A.Head'. All other values are the empty --- string. -instance Empty A.Repository where - empty = A.Repository - { A.repoVcs = A.Git - , A.repoKind = A.Head - , A.repoLocation = "" - , A.repoBranch = "" - , A.repoTag = "" - , A.repoSubdir = "" - } - --- | A default 'A.Flag'. 'A.flName' and 'A.flDescription' are --- empty; 'A.flDefault' is 'True', and 'A.flManual' is 'False'. -instance Empty A.Flag where - empty = A.Flag - { A.flName = "" - , A.flDescription = "" - , A.flDefault = True - , A.flManual = False - } diff --git a/lib/Cartel/GenCartelCabal.hs b/lib/Cartel/GenCartelCabal.hs new file mode 100644 --- /dev/null +++ b/lib/Cartel/GenCartelCabal.hs @@ -0,0 +1,117 @@ +-- | This program generates Cartel's own Cabal file. It's included +-- here in the library to provide a live, type-checked, compilable +-- example. You will want to look at the source code itself, as the +-- Haddocks won't show you much. + +module Cartel.GenCartelCabal where + +import Cartel +import qualified Cartel.Version + +-- Dependencies + +base :: Package +base = closedOpen "base" [4,5,0,0] [4,8] + +directory :: Package +directory = closedOpen "directory" [1,1,0,2] [1,3] + +filepath :: Package +filepath = closedOpen "filepath" [1,3,0,0] [1,4] + +time :: Package +time = closedOpen "time" [1,4] [1,6] + +quickcheck :: Package +quickcheck = nextBreaking "QuickCheck" [2,7] + +random :: Package +random = closedOpen "random" [1,1] [1,2] + +transformers :: Package +transformers = nextBreaking "transformers" [0,4] + +multiarg :: Package +multiarg = nextBreaking "multiarg" [0,30,0,0] + +quickpull :: Package +quickpull = nextBreaking "quickpull" [0,4,0,0] + +libDepends :: [Package] +libDepends = + [ base, directory, filepath, time, transformers ] + +testDepends :: [Package] +testDepends = [ multiarg, quickcheck, random, quickpull ] + +commonOptions :: HasBuildInfo a => [a] +commonOptions = + [ ghcOptions ["-Wall"] + , hsSourceDirs ["lib"] + , buildDepends libDepends + ] + +testOptions :: HasBuildInfo a => [a] +testOptions + = hsSourceDirs ["tests"] + : buildDepends testDepends + : commonOptions + +main :: IO () +main = defaultMain $ do + libModules <- modules "lib" + flagVisual <- makeFlag "visual" + (FlagOpts { flagDescription = "Build cartel-visual-test executable." + , flagDefault = False + , flagManual = True + }) + testMods <- modules "tests" + return + ( blank + { name = "cartel" + , version = Cartel.Version.version + , buildType = Just simple + , category = "Distribution" + , maintainer = "omari@smileystation.com" + , synopsis = "Specify Cabal files in Haskell" + , description = + [ "By specifying your Cabal files in Haskell, you have the power" + , "of Haskell at your disposal to reduce redundancy. You can" + , "also read in trees of module names dynamically, which saves" + , "you from manually maintaining lists of module names." + , "" + , "See the documentation in the \"Cartel\" module for details." + ] + , license = Just bsd3 + , licenseFile = "LICENSE" + , copyright = "Copyright 2014-2015 Omari Norman" + , author = "Omari Norman" + , stability = "Experimental" + , cabalVersion = Just (1,16) + , homepage = "http://www.github.com/massysett/cartel" + , bugReports = "http://www.github.com/massysett/cartel/issues" + , testedWith = let f v = (ghc, eq v) + in map f [[7,6,3], [7,8,2]] + , extraSourceFiles = ["README.md"] + } + , exposedModules libModules : haskell2010 : commonOptions + + , [ githubHead "massysett" "cartel" + , executable "cartel-visual-test" + [ condBlock (flag flagVisual) + ( buildable True + , otherModules testMods : testOptions + ) + [ buildable False + ] + , haskell2010 + , mainIs "cartel-visual-test.hs" + ] + , testSuite "cartel-properties" + $ haskell2010 + : otherModules testMods + : testOptions + ++ exitcodeFields "cartel-properties.hs" + + ] + ) diff --git a/lib/Cartel/Render.hs b/lib/Cartel/Render.hs --- a/lib/Cartel/Render.hs +++ b/lib/Cartel/Render.hs @@ -1,17 +1,23 @@ --- | Functions to render the data types in "Cartel.Ast". You --- shouldn't need anything from this module; the main rendering --- function is also exported from "Cartel". +{-# LANGUAGE FlexibleInstances #-} +-- | Reducing a Cartel AST to flat Cabal text; essentially a +-- pretty-printer. module Cartel.Render where -import qualified Cartel.Ast as A +import Data.Word +import Cartel.Betsy +import Cartel.Ast import Data.List (intersperse) +-- | Separate two strings with a space, but only if both strings are +-- not empty. (<+>) :: String -> String -> String l <+> r | null l = r | null r = l | otherwise = l ++ " " ++ r +-- | Concatenate several vertically. Unlike 'unlines', does not add a +-- newline when an item is 'null' or when the accumulator is 'null'. vsep :: [String] -> String vsep = foldr f "" where @@ -23,38 +29,52 @@ indentAmt :: Int indentAmt = 2 +-- | Indents a line of text; adds a newline at the end. indent :: Int -> String -> String indent i s = replicate (i * indentAmt) ' ' ++ s ++ "\n" -indentList :: Int -> [String] -> String +-- | Creates a comma-separated indented representation for a list of +-- items, such as a list of filenames or modules. Each line ends with +-- a newline. +indentList + :: Renderable a + => Int + -- ^ Indentation level. + -> [a] + -> String indentList i ls = case ls of [] -> "" x:[] -> line1 x x:xs -> concat $ line1 x : map lineRest xs where - line1 s = replicate (i * indentAmt + 2) ' ' ++ s ++ "\n" - lineRest s = replicate (i * indentAmt) ' ' ++ ", " ++ s ++ "\n" + line1 s = replicate (i * indentAmt + 2) ' ' ++ render s ++ "\n" + lineRest s = replicate (i * indentAmt) ' ' + ++ ", " ++ render s ++ "\n" labeled - :: Int + :: Renderable a + => Int -- ^ Indentation -> String -- ^ Label - -> String + -> a -- ^ Text -> String -- ^ Result, with a newline. Empty if the text to show is also -- empty. labeled i l t - | null t = "" - | otherwise = indent i (l ++ ": " ++ t) + | null txt = "" + | otherwise = indent i (l ++ ": " ++ txt) + where + txt = render t labeledList - :: Int + :: Renderable a + => Int -- ^ Indentation -> String -- ^ Label - -> [String] + -> [a] -- ^ List -> String -- ^ Result, with newlines. Empty if the list is empty. @@ -62,277 +82,305 @@ | null ts = "" | otherwise = indent i (l ++ ":") ++ indentList (i + 1) ts -version :: A.Version -> String -version = concat . intersperse "." . map show . A.unVersion +-- | Render an item. The rendered text shall contain no newlines. +class Renderable a where + render :: a -> String -license :: A.License -> String -license = show +instance Renderable String where + render = id -buildType :: A.BuildType -> String -buildType = show +instance Renderable a => Renderable (Maybe a) where + render = maybe "" render -compiler :: A.Compiler -> String -compiler = show +-- | Render an item. The rendered text must contain a newline at the +-- end of each line and must end with a newline. The leftmost line of +-- the rendered text shall be indented by the given number of +-- indentation levels (the number of spaces in each level is set by +-- 'indentAmt'). +-- +-- If there are no lines to indent, return an empty string. +class RenderableIndented a where + renderIndented :: Int -> a -> String -comparison :: Ordering -> String -comparison a = case a of - LT -> "<" - GT -> ">" - EQ -> "==" -constraint :: A.Constraint -> String -constraint a = comparison (A.csComparison a) <+> - version (A.csVersion a) +instance RenderableIndented Error where + renderIndented i e = concatMap (indent i) $ + "Error while attempting to generate Cabal file from Cartel source." + : case e of + DuplicateFlag nm -> + ["Duplicated flag: " ++ (flagNameHead nm : flagNameTail nm)] + Failed s -> ["The \"fail\" function was invoked: " ++ s] + EmptyFlagName -> ["Empty flag name"] -logical :: A.Logical -> String -logical a = case a of - A.Or -> "||" - A.And -> "&&" +instance Renderable BuildType where + render = show -constrTree :: A.ConstrTree -> String -constrTree a = case a of - A.Leaf c -> constraint c - A.Branch c l r -> "(" ++ constrTree l - <+> logical c <+> constrTree r ++ ")" +instance Renderable License where + render = show -cabalVersion :: (Int, Int) -> String -cabalVersion (a, b) = ">= " ++ show a ++ "." ++ show b +instance Renderable Compiler where + render = show -description :: [String] -> String -description ls - | null ls = "" - | otherwise = concatMap f ls - where - f s - | null s = " .\n" - | otherwise = " " ++ s ++ "\n" +instance Renderable Ordering where + render LT = "<" + render GT = ">" + render EQ = "==" -testedWith :: [(A.Compiler, A.ConstrTree)] -> String -testedWith = concat . intersperse ", " . map f - where - f (cmp, cst) = compiler cmp <+> constrTree cst +instance Renderable Version where + render = concat . intersperse "." . map show -properties :: A.Properties -> String -properties p - = lbl "name" (A.prName p) - ++ lbl "version" (version . A.prVersion $ p) - ++ lbl "cabal-version" (cabalVersion . A.prCabalVersion $ p) - ++ lbl "build-type" (buildType . A.prBuildType $ p) - ++ lbl "license" (license . A.prLicense $ p) - ++ lbl "license-file" (A.prLicenseFile p) - ++ lst "license-files" (A.prLicenseFiles p) - ++ lbl "copyright" (A.prCopyright p) - ++ lbl "author" (A.prAuthor p) - ++ lbl "maintainer" (A.prMaintainer p) - ++ lbl "stability" (A.prStability p) - ++ lbl "homepage" (A.prHomepage p) - ++ lbl "bug-reports" (A.prBugReports p) - ++ lbl "package-url" (A.prPackageUrl p) - ++ lbl "synopsis" (A.prSynopsis p) - ++ let desc = description . A.prDescription $ p - lbld | null desc = "" - | otherwise = "description:\n" ++ desc - in lbld - ++ lbl "category" (A.prCategory p) - ++ lbl "tested-with" (testedWith . A.prTestedWith $ p) - ++ lst "data-files" (A.prDataFiles p) - ++ lbl "data-dir" (A.prDataDir p) - ++ lst "extra-source-files" (A.prExtraSourceFiles p) - ++ lst "extra-doc-files" (A.prExtraDocFiles p) - ++ lst "extra-tmp-files" (A.prExtraTmpFiles p) - where - lbl = labeled 0 - lst = labeledList 0 +instance Renderable Constraint where + render AnyVersion = "" + render (Constrained t) = render t -class Field a where - field :: Int -> a -> String +instance Renderable Logical where + render Or = "||" + render And = "&&" -instance Field A.LibraryField where - field i f = case f of - A.LibExposedModules xs -> labeledList i "exposed-modules" xs - A.LibExposed b -> labeled i "exposed" (show b) - A.LibConditional b -> condBlock i b - A.LibInfo b -> field i b +instance Renderable ConstrTree where + render (Leaf o v) = render o <+> render v + render (Branch c l r) = "(" ++ render l + <+> render c <+> render r ++ ")" -library :: A.Library -> String -library (A.Library l) = "Library\n" - ++ concatMap (field 1) l +instance Renderable (Word, Word) where + render (a, b) = ">= " ++ show a ++ "." ++ show b -instance Field A.ExecutableField where - field i f = case f of - A.ExeMainIs s -> labeled i "main-is" s - A.ExeConditional b -> condBlock i b - A.ExeInfo b -> field i b +newtype Description = Description [String] + deriving (Eq, Ord, Show) -executable :: A.Executable -> String -executable (A.Executable n fs) = - "Executable " ++ n ++ "\n" - ++ concatMap (field 1) fs +instance RenderableIndented Description where + renderIndented i (Description ls) + | null ls = "" + | otherwise = concatMap f ls + where + f s + | null s = indent i "." + | otherwise = indent i s -testSuiteType :: A.TestSuiteType -> String -testSuiteType t = case t of - A.ExitcodeStdio -> "exitcode-stdio-1.0" - A.Detailed -> "detailed-1.0" +instance Renderable (Compiler, Constraint) where + render (cmp, cst) = render cmp <+> render cst -instance Field A.TestSuiteField where - field i t = case t of - A.TestType a -> labeled i "type" (testSuiteType a) - A.TestMainIs s -> labeled i "main-is" s - A.TestModule s -> labeled i "test-module" s - A.TestConditional b -> condBlock i b - A.TestInfo b -> field i b +instance Renderable FlagName where + render nm = flagNameHead nm : flagNameTail nm -testSuite :: A.TestSuite -> String -testSuite (A.TestSuite n fs) = - "Test-Suite " ++ n ++ "\n" - ++ concatMap (field 1) fs +instance RenderableIndented (FlagName, FlagOpts) where + renderIndented i (nm, (FlagOpts desc df man)) = + indent i ("Flag " ++ render nm) + ++ labeled next "description" desc + ++ labeled next "default" df + ++ labeled next "manual" man + where + next = i + 1 -instance Field A.BenchmarkField where - field i b = case b of - A.BenchmarkConditional s -> condBlock i s - A.BenchmarkInfo a -> field i a +instance RenderableIndented [(FlagName, FlagOpts)] where + renderIndented i = vsep . map (renderIndented i) -benchmark :: A.Benchmark -> String -benchmark (A.Benchmark n mi fs) = - "Benchmark " ++ n ++ "\n" - ++ labeled 1 "main-is" mi - ++ labeled 1 "interface" "exitcode-stdio-1.0" - ++ concatMap (field 1) fs +instance Renderable CondLeaf where + render a = case a of + OS s -> "os(" ++ s ++ ")" + Arch s -> "arch(" ++ s ++ ")" + Impl cmp constr -> "impl(" ++ s ++ ")" + where + s = render cmp <+> render constr + CFlag f -> "flag(" ++ render f ++ ")" + CTrue -> "true" + CFalse -> "false" -condBlock :: Field a => Int -> A.CondBlock a -> String -condBlock i b = - indent i ("if " ++ condTree (A.condIf b)) - ++ concatMap (field (i + 1)) (A.ifTrue b) - ++ elses - where - elses | null (A.ifElse b) = "" - | otherwise = indent i "else" - ++ concatMap (field (i + 1)) (A.ifElse b) +instance Renderable RepoKind where + render Head = "head" + render This = "this" -package :: A.Package -> String -package p = - A.packName p <+> maybe "" constrTree (A.packConstraints p) +instance Renderable Vcs where + render x = case x of + Darcs -> "darcs" + Git -> "git" + Svn -> "svn" + Cvs _ -> "cvs" + Mercurial -> "mercurial" + Bazaar -> "bazaar" + ArchVcs -> "arch" + Monotone -> "monotone" -language :: A.Language -> String -language = show +instance RenderableIndented Repository where + renderIndented i r = + indent i ("source-repository " ++ render (repoKind r)) + ++ lbl "type" (repoVcs r) + ++ lbl "location" (repoLocation r) + ++ lbl "module" mdle + ++ lbl "branch" (repoBranch r) + ++ lbl "tag" (repoTag r) + ++ lbl "subdir" (repoSubdir r) + where + mdle = case repoVcs r of + Just (Cvs s) -> s + _ -> "" + lbl x = labeled (i + 1) x -instance Field A.BuildInfoField where - field i fld = case fld of - A.BuildDepends ps -> - labeledList i "build-depends" . map package $ ps - A.OtherModules ls -> - labeledList i "other-modules" ls - A.HsSourceDirs ls -> - labeledList i "hs-source-dirs" ls - A.Extensions ls -> - labeledList i "extensions" ls - A.BuildTools ps -> - labeledList i "build-tools" . map package $ ps - A.Buildable b -> - labeled i "buildable" . show $ b - A.GHCOptions ps -> - labeledList i "ghc-options" ps - A.GHCProfOptions ps -> - labeledList i "ghc-prof-options" ps - A.GHCSharedOptions ps -> - labeledList i "ghc-shared-options" ps - A.HugsOptions ps -> - labeledList i "hugs-options" ps - A.Nhc98Options ps -> - labeledList i "nhc98-options" ps - A.Includes ps -> - labeledList i "includes" ps - A.InstallIncludes ps -> - labeledList i "install-includes" ps - A.IncludeDirs ps -> - labeledList i "include-dirs" ps - A.CSources ps -> - labeledList i "c-sources" ps - A.ExtraLibraries ps -> - labeledList i "extra-libraries" ps - A.ExtraLibDirs ps -> - labeledList i "extra-lib-dirs" ps - A.CCOptions ps -> - labeledList i "cc-options" ps - A.CPPOptions ps -> - labeledList i "cpp-options" ps - A.LDOptions ps -> - labeledList i "ld-options" ps - A.PkgConfigDepends ps -> - labeledList i "pkgconfig-depends" . map package $ ps - A.Frameworks ps -> - labeledList i "frameworks" ps - A.DefaultLanguage l - -> labeled i "default-language" . language $ l +instance Renderable Package where + render (Package nm cs) + = nm <+> render cs + +instance Renderable Bool where + render = show -condition :: A.Condition -> String -condition a = case a of - A.OS s -> "os(" ++ s ++ ")" - A.Arch s -> "arch(" ++ s ++ ")" - A.Impl (cmp, mayC) -> "impl(" ++ s ++ ")" +instance Renderable DefaultLanguage where + render = show + +instance RenderableIndented BuildInfoField where + renderIndented i fld = case fld of + BuildDepends ls -> lst "build-depends" ls + OtherModules ls -> lst "other-modules" ls + HsSourceDirs ls -> lst "hs-source-dirs" ls + Extensions ls -> lst "extensions" ls + BuildTools ls -> lst "build-tools" ls + Buildable b -> lbl "buildable" b + GHCOptions ls -> lst "ghc-options" ls + GHCProfOptions ls -> lst "ghc-prof-options" ls + GHCSharedOptions ls -> lst "ghc-shared-options" ls + HugsOptions ls -> lst "hugs-options" ls + Nhc98Options ls -> lst "nhc98-options" ls + Includes ls -> lst "includes" ls + InstallIncludes ls -> lst "install-includes" ls + IncludeDirs ls -> lst "include-dirs" ls + CSources ls -> lst "c-sources" ls + ExtraLibraries ls -> lst "extra-libraries" ls + ExtraLibDirs ls -> lst "extra-lib-dirs" ls + CCOptions ls -> lst "cc-options" ls + CPPOptions ls -> lst "cpp-options" ls + LDOptions ls -> lst "ld-options" ls + PkgConfigDepends ls -> lst "pkgconfig-depends" ls + Frameworks ls -> lst "frameworks" ls + DefaultLanguage df -> lbl "default-language" df where - s = compiler cmp <+> cond - cond = maybe "" constrTree mayC - A.CFlag f -> "flag(" ++ f ++ ")" - A.CTrue -> "true" - A.CFalse -> "false" + -- don't do @lst = labeledList i@ - monomorphism restriction + lst l = labeledList i l + lbl l = labeled i l -condTree :: A.CondTree -> String -condTree a = case a of - A.CLeaf c -> condition c - A.CBranch b l r -> "(" ++ condTree l <+> logical b <+> condTree r - ++ ")" - A.CNegate t -> "!(" ++ condTree t ++ ")" +instance RenderableIndented LibraryField where + renderIndented i fld = case fld of + ExposedModules ls -> lst "exposed-modules" ls + Exposed b -> lbl "exposed" b + LibConditional b -> renderIndented i b + LibInfo b -> renderIndented i b + where + lst l = labeledList i l + lbl l = labeled i l -flag :: A.Flag -> String -flag (A.Flag nm desc dflt man) = concat (line1:lineRest) - where - line1 = "Flag " ++ nm ++ "\n" - lineRest = map (indent 1) - [ "Description: " ++ desc - , "Default: " ++ show dflt - , "Manual: " ++ show man - ] +instance Renderable Condition where + render tree = case tree of + CLeaf c -> render c + CBranch c l r -> ("(" ++ render l) + <+> render c <+> (render r ++ ")") + CNegate t -> "!(" ++ render t ++ ")" -vcs :: A.Vcs -> String -vcs a = case a of - A.Darcs -> "darcs" - A.Git -> "git" - A.Svn -> "svn" - A.Cvs _ -> "cvs" - A.Mercurial -> "mercurial" - A.Bazaar -> "bazaar" - A.ArchVcs -> "arch" - A.Monotone -> "monotone" +instance RenderableIndented a => RenderableIndented (CondBlock a) where + renderIndented i (CondBlock cond (y1, ys) nos) = + indent i ("if" <+> render cond) + ++ renderIndented (i + 1) y1 + ++ concatMap (renderIndented (i + 1)) ys + ++ elses + where + elses | null nos = "" + | otherwise = indent i "else" + ++ concatMap (renderIndented (i + 1)) nos -repoKind :: A.RepoKind -> String -repoKind a = case a of - A.Head -> "head" - A.This -> "this" +instance RenderableIndented ExecutableField where + renderIndented i fld = case fld of + ExeConditional b -> renderIndented i b + ExeInfo b -> renderIndented i b + ExeMainIs m -> labeled i "main-is" m -repository :: A.Repository -> String -repository r = - "source-repository " ++ repoKind (A.repoKind r) ++ "\n" - ++ lbl "type" (vcs . A.repoVcs $ r) - ++ lbl "location" (A.repoLocation r) - ++ lbl "module" mdle - ++ lbl "branch" (A.repoBranch r) - ++ lbl "tag" (A.repoTag r) - ++ lbl "subdir" (A.repoSubdir r) - where - mdle = case A.repoVcs r of - A.Cvs s -> s - _ -> "" - lbl = labeled 1 +instance RenderableIndented Executable where + renderIndented i (Executable nm flds) = + indent i ("Executable " ++ nm) + ++ concatMap (renderIndented next) flds + where + next = i + 1 -cabal :: A.Cabal -> String -cabal d = vsep - [ properties . A.cProperties $ d - , vsep . map repository . A.cRepositories $ d - , vsep . map flag . A.cFlags $ d - , maybe "" library . A.cLibrary $ d - , vsep . map executable . A.cExecutables $ d - , vsep . map testSuite . A.cTestSuites $ d - , vsep . map benchmark . A.cBenchmarks $ d - ] +instance Renderable TestSuiteType where + render ExitcodeStdio = "exitcode-stdio-1.0" + render Detailed = "detailed-0.9" + +instance RenderableIndented TestSuiteField where + renderIndented i fld = case fld of + TestConditional c -> renderIndented i c + TestInfo b -> renderIndented i b + TestMainIs m -> labeled i "main-is" m + TestSuiteType t -> labeled i "type" t + TestModule m -> labeled i "test-module" m + +instance RenderableIndented TestSuite where + renderIndented i (TestSuite n flds) = + indent i ("Test-Suite " ++ n) + ++ concatMap (renderIndented next) flds + where + next = i + 1 + +instance Renderable BenchmarkType where + render BenchExitCode = "exitcode-stdio-1.0" + +instance RenderableIndented BenchmarkField where + renderIndented i (BenchmarkConditional b) = renderIndented i b + renderIndented i (BenchmarkInfo b) = renderIndented i b + renderIndented i (BenchmarkMainIs b) = labeled i "main-is" b + renderIndented i (BenchmarkType b) = labeled i "type" b + +instance RenderableIndented Benchmark where + renderIndented i (Benchmark nm flds) = + indent i ("Benchmark " ++ nm) + ++ concatMap (renderIndented next) flds + where + next = i + 1 + +instance RenderableIndented Properties where + renderIndented i c = + lbl "name" (name c) + ++ lbl "version" (version c) + ++ lbl "cabal-version" (maybe "" render . cabalVersion $ c) + ++ lbl "license" (maybe "" render . license $ c) + ++ lbl "license-file" (licenseFile c) + ++ lst "license-files" (licenseFiles c) + ++ lbl "build-type" (maybe "" render . buildType $ c) + ++ lbl "copyright" (copyright c) + ++ lbl "author" (author c) + ++ lbl "maintainer" (maintainer c) + ++ lbl "stability" (stability c) + ++ lbl "homepage" (homepage c) + ++ lbl "bug-reports" (bugReports c) + ++ lbl "package-url" (packageUrl c) + ++ lbl "synopsis" (synopsis c) + ++ indent i "description:" + ++ renderIndented (i + 1) (Description . description $ c) + ++ lbl "category" (category c) + ++ labeledList i "tested-with" (testedWith c) + ++ lst "data-files" (dataFiles c) + ++ lbl "data-dir" (dataDir c) + ++ lst "extra-source-files" (extraSourceFiles c) + ++ lst "extra-doc-files" (extraDocFiles c) + ++ lst "extra-tmp-files" (extraTmpFiles c) + where + lbl l = labeled i l + lst l = labeledList i l + +renLibrary :: Int -> [LibraryField] -> String +renLibrary _ [] = "" +renLibrary lvl xs = indent lvl "Library" + ++ concatMap (renderIndented (lvl + 1)) xs + +instance RenderableIndented Section where + renderIndented i s = case s of + SecRepo x -> ren x + SecExe x -> ren x + SecTest x -> ren x + SecBench x -> ren x + where + ren x = renderIndented i x + +instance RenderableIndented Cabal where + renderIndented i (Cabal prop lib secs) + = vsep $ ren prop + : renLibrary 0 lib + : map ren secs + where + ren x = renderIndented i x diff --git a/lib/Cartel/Tools.hs b/lib/Cartel/Tools.hs deleted file mode 100644 --- a/lib/Cartel/Tools.hs +++ /dev/null @@ -1,519 +0,0 @@ -module Cartel.Tools - ( -- * Logic trees - LogicTree(..) - - -- * Building constraints - - -- | Helpers to build many common version constraints. - - -- ** Building constraint trees - , lt - , gt - , eq - , ltEq - , gtEq - - -- ** Building package specifications - , closedOpen - , apiVersion - , nextBreaking - , nextMajor - , exactly - - -- * Field class - , Field(..) - - -- ** Conditionals - , cif - , system - , arch - , impl - , flag - , true - , false - - -- ** Build info builders - , buildDepends - , otherModules - , hsSourceDirs - , extensions - , buildTools - , buildable - , ghcOptions - , ghcProfOptions - , ghcSharedOptions - , hugsOptions - , nhc98Options - , includes - , installIncludes - , includeDirs - , cSources - , extraLibraries - , extraLibDirs - , ccOptions - , cppOptions - , ldOptions - , pkgConfigDepends - , frameworks - , defaultLanguage - - -- * Rendering a cabal file - , render - , renderString - - -- * Getting a list of all modules in a directory tree - , modules - , fileExtensions - , modulesWithExtensions - ) where - -import qualified Cartel.Ast as A -import qualified Cartel.Render as R -import qualified System.Directory as D -import qualified System.FilePath as P -import System.FilePath (()) -import qualified Data.Char as C -import Data.List (intersperse, sortBy) -import Data.Monoid -import qualified Data.Version as V -import Data.Time -import qualified Paths_cartel -import qualified System.IO as IO - -class LogicTree a where - (&&&) :: a -> a -> a - (|||) :: a -> a -> a - -infixr 3 &&& -infixr 2 ||| - -instance LogicTree A.ConstrTree where - l &&& r = A.Branch A.And l r - l ||| r = A.Branch A.Or l r - -instance LogicTree A.CondTree where - l &&& r = A.CBranch A.And l r - l ||| r = A.CBranch A.Or l r - - -lt :: [Int] -> A.ConstrTree -lt = A.Leaf . A.Constraint LT . A.Version - -gt :: [Int] -> A.ConstrTree -gt = A.Leaf . A.Constraint GT . A.Version - -eq :: [Int] -> A.ConstrTree -eq = A.Leaf . A.Constraint EQ . A.Version - -ltEq :: [Int] -> A.ConstrTree -ltEq v = lt v ||| eq v - -gtEq :: [Int] -> A.ConstrTree -gtEq v = gt v ||| eq v - --- | Creates a package interval that is closed on the left, open on --- the right. Useful for the common case under the PVP to specify --- that you depend on a version that is at least a particular --- version, but less than another version. --- --- > closedOpen "bytestring" [0,17] [0,19] ==> bytestring >= 0.17 && < 0.19 - -closedOpen - :: String - -- ^ Package name - -> [Int] - -- ^ Version number for lower bound - -> [Int] - -- ^ Version number for upper bound - -> A.Package - -- ^ Resulting contraints -closedOpen n l u = A.Package n $ Just (gtEq l &&& lt u) - --- | Specifies a particular API version. Useful to lock your --- package dependencies down to a particular API version. --- --- > apiVersion "base" [1] ==> base >= 1 && < 2 --- > apiVersion "base" [1,2] ==> base >= 1.2 && < 1.3 --- > apiVersion "base" [1,2,3] ==> base >= 1.2.3 && < 1.2.4 - -apiVersion :: String -> [Int] -> A.Package -apiVersion n v = closedOpen n v u - where - u = case v of - [] -> error "apiVersion: requires a non-empty list argument" - _ -> init v ++ [succ (last v)] - --- | Depends on the version given, up to the next breaking API --- change. --- --- > nextBreaking "base" [4] ==> base >= 4 && < 4.1 --- > nextBreaking "base" [4,1] ==> base >= 4.1 && < 4.2 --- > nextBreaking "base" [4,7,0,0] ==> base >= 4.7.0.0 && < 4.8 - -nextBreaking - :: String - -> [Int] - -> A.Package -nextBreaking n v = closedOpen n v u - where - u = case v of - [] -> error "nextBreaking: requires a non-empty list argument" - x:[] -> [x, 1] - x:y:_ -> x : succ y : [] - --- | Depends on the version given, up to the next time the first --- digit increments. Useful for @base@. --- --- > nextBreaking "base" [4] ==> base >= 4 && < 5 - -nextMajor - :: String - -> [Int] - -> A.Package -nextMajor n v = closedOpen n v u - where - u = case v of - [] -> error "nextMajor: requires a non-empty list argument" - x:_ -> succ x : [] - --- | Depends on exactly this version only. --- --- > exactly "base" [4,5,0,0] ==> base ==4.5.0.0 - -exactly :: String -> [Int] -> A.Package -exactly n v = A.Package n (Just $ eq v) - --- | Common extensions of Haskell files and files that are --- preprocessed into Haskell files. Includes: --- --- * hs (Haskell) --- --- * lhs (literate Haskell) --- --- * gc (greencard) --- --- * chs (c2hs) --- --- * hsc (hsc2hs) --- --- * y and ly (happy) --- --- * x (alex) --- --- * cpphs - -fileExtensions :: [String] -fileExtensions = - [ "hs" - , "lhs" - , "gc" - , "chs" - , "hsc" - , "y" - , "ly" - , "x" - , "cpphs" - ] - -interestingFile - :: [String] - -- ^ Extensions of module files - -> FilePath - -> Bool - -interestingFile xs s = case s of - "" -> False - x:_ - | not (C.isUpper x) -> False - | otherwise -> let mayExt = P.takeExtension s - in case mayExt of - [] -> False - _ : ext -> ext `elem` xs - -interestingDir :: FilePath -> Bool -interestingDir p = case p of - [] -> False - x:_ - | not (C.isUpper x) -> False - | otherwise -> not $ '.' `elem` p - --- | Gets all Haskell modules in a given directory tree. Only files --- with one of the extensions listed in 'fileExtensions' are --- returned. Files and directories that do not begin with an --- uppercase letter are ignored. (This also ignores files that --- start with a dot.) Directories with a dot anywhere in the name --- are ignored. - -modules - :: FilePath - -- ^ Start searching within this directory. - -> IO [String] - -- ^ A list of Haskell modules in the given directory tree. The - -- file contents are not examined; only the file names matter. - -- Returned as a list of dotted names. -modules = modulesWithExtensions fileExtensions - - --- | Gets all Haskell modules in a given directory tree. Allows you --- to specify what extensions you are interested in. - -modulesWithExtensions - :: [String] - -- ^ Look for files that have one of these extensions. - -- 'fileExtensions' covers the most common cases. Files without - -- one of these extensions are ignored. Files and directories - -- that do not begin with an uppercase letter are ignored. (This - -- also ignores files that start with a dot.) Directories with a - -- dot anywhere in the name are ignored. - - -> FilePath - -- ^ Start searching within this directory. - - -> IO [String] - -- ^ A list of Haskell modules in the given directory tree. The - -- file contents are not examined; only the file names matter. - -- Returned as a list of dotted names. - -modulesWithExtensions exts start - = fmap (map modName . sortBy sorter . map reverse) - $ modulesInDir exts start [] - where - modName = concat . intersperse "." - -sorter :: [String] -> [String] -> Ordering -sorter x y = mconcat (zipWith compare x y) <> compare lenX lenY - where - (lenX, lenY) = (length x, length y) - -modulesInDir - :: [String] - -- ^ Extensions of module files - -> FilePath - -- Search is rooted in this directory - -> [FilePath] - -- ^ Stack of directories we're in - -> IO [[String]] - -- ^ Returns a list of modules in this directory. -modulesInDir exts start dirs = do - cs <- D.getDirectoryContents (start P.joinPath (reverse dirs)) - fmap concat . mapM (processFile exts start dirs) $ cs - -processFile - :: [String] - -- ^ Extensions of module files - -> FilePath - -- ^ Search is rooted in this directory - -> [FilePath] - -- Stack of directories we're in, including current directory - -> FilePath - -- ^ Interesting file under investigation - -> IO [[String]] -processFile exts start dirs this = do - isDir <- D.doesDirectoryExist - (start (P.joinPath . reverse $ this : dirs)) - if isDir - then if interestingDir this - then modulesInDir exts start (this : dirs) - else return [] - else return $ if interestingFile exts this - then [(P.dropExtension this : dirs)] - else [] - --- | Things that can be an item in a field in a Cabal file. -class Field a where - - -- | Takes a conditional block and wraps it in the field type. - conditional :: A.CondBlock a -> a - - -- | Takes a build information field and wraps it in the field - -- type. - buildInfo :: A.BuildInfoField -> a - -instance Field A.LibraryField where - conditional = A.LibConditional - buildInfo = A.LibInfo - -instance Field A.ExecutableField where - conditional = A.ExeConditional - buildInfo = A.ExeInfo - -instance Field A.TestSuiteField where - conditional = A.TestConditional - buildInfo = A.TestInfo - -instance Field A.BenchmarkField where - conditional = A.BenchmarkConditional - buildInfo = A.BenchmarkInfo - --- # Build info helpers -buildDepends :: Field a => [A.Package] -> a -buildDepends = buildInfo . A.BuildDepends - -otherModules :: Field a => [String] -> a -otherModules = buildInfo . A.OtherModules - -hsSourceDirs :: Field a => [String] -> a -hsSourceDirs = buildInfo . A.HsSourceDirs - -extensions :: Field a => [String] -> a -extensions = buildInfo . A.Extensions - -buildTools :: Field a => [A.Package] -> a -buildTools = buildInfo . A.BuildTools - -buildable :: Field a => Bool -> a -buildable = buildInfo . A.Buildable - -ghcOptions :: Field a => [String] -> a -ghcOptions = buildInfo . A.GHCOptions - -ghcProfOptions :: Field a => [String] -> a -ghcProfOptions = buildInfo . A.GHCProfOptions - -ghcSharedOptions :: Field a => [String] -> a -ghcSharedOptions = buildInfo . A.GHCSharedOptions - -hugsOptions :: Field a => [String] -> a -hugsOptions = buildInfo . A.HugsOptions - -nhc98Options :: Field a => [String] -> a -nhc98Options = buildInfo . A.Nhc98Options - -includes :: Field a => [String] -> a -includes = buildInfo . A.Includes - -installIncludes :: Field a => [String] -> a -installIncludes = buildInfo . A.InstallIncludes - -includeDirs :: Field a => [String] -> a -includeDirs = buildInfo . A.IncludeDirs - -cSources :: Field a => [String] -> a -cSources = buildInfo . A.CSources - -extraLibraries :: Field a => [String] -> a -extraLibraries = buildInfo . A.ExtraLibraries - -extraLibDirs :: Field a => [String] -> a -extraLibDirs = buildInfo . A.ExtraLibDirs - -ccOptions :: Field a => [String] -> a -ccOptions = buildInfo . A.CCOptions - -cppOptions :: Field a => [String] -> a -cppOptions = buildInfo . A.CPPOptions - -ldOptions :: Field a => [String] -> a -ldOptions = buildInfo . A.LDOptions - -pkgConfigDepends :: Field a => [A.Package] -> a -pkgConfigDepends = buildInfo . A.PkgConfigDepends - -frameworks :: Field a => [String] -> a -frameworks = buildInfo . A.Frameworks - -defaultLanguage :: Field a => A.Language -> a -defaultLanguage = buildInfo . A.DefaultLanguage - --- | Builds @if@ statements. Use with the following functions, such --- as 'flag', to make it easy to build conditional blocks. For --- example: --- --- > cif (flag "buildExe") [buildable True] [buildable False] --- --- A little more complicated: --- --- > cif (flag "buildExe" &&& system "windows") --- > [buildable True] [buildable False] -cif - :: Field a - => A.CondTree - -- ^ Condition to satisfy - -> [a] - -- ^ Use these results if condition is true - -> [a] - -- ^ Use these results if condition if false - -> a -cif tree ifTrue ifFalse = - conditional $ A.CondBlock tree ifTrue ifFalse - --- | Operating system; tested against @System.Info.os@ on the --- target system. -system :: String -> A.CondTree -system = A.CLeaf . A.OS - --- | Argument is matched against @System.Info.arch@ on the target --- system. -arch :: String -> A.CondTree -arch = A.CLeaf . A.Arch - --- | Tests for the configured Haskell implementation. -impl :: A.Compiler -> Maybe A.ConstrTree -> A.CondTree -impl cm cn = A.CLeaf $ A.Impl (cm, cn) - --- | Evaluates to the current assignment of the flag of the given --- name. Flag names are case insensitive. Testing for flags that --- have not been introduced with a flag section is an error. -flag :: String -> A.CondTree -flag = A.CLeaf . A.CFlag - --- | Always true. -true :: A.CondTree -true = A.CLeaf A.CTrue - --- | Always false. -false :: A.CondTree -false = A.CLeaf A.CFalse - - --- | Renders a 'A.Cabal' data type as a string. -renderString - :: String - -- ^ Name of program used - -> ZonedTime - -- ^ When this output is being created - -> V.Version - -- ^ Cartel package version - -> A.Cabal - -> String -renderString nm zt ver cbl = hdr ++ R.cabal cbl - where - hdr = unlines $ - [ "-- This Cabal file generated using the Cartel library." - , "-- Cartel is available at:" - , "-- http://www.github.com/massysett/cartel" - , "--" - ] ++ case nm of - [] -> [] - _ -> ["-- Script name used to generate: " ++ nm] - ++ - [ "-- Generated on: " ++ show zt - , "-- Cartel library version: " ++ showVer - ] - showVer = concat - . intersperse "." - . map show - . V.versionBranch - $ ver - --- | Render a Cabal file to standard output. The output will have --- comments at the beginning indicating that it was built with --- Cartel, and what version of the Cartel library was used, and when --- the output was produced, along with (optionally) the filename of --- the program used to produce the output. --- --- Ensures that the output is UTF-8, as required by Cabal. -render - :: String - -- ^ The name of the program used to produce this output. Put the - -- name of your script here so it can appear in the output. This - -- is optional; to omit it, use the empty string here. - - -> A.Cabal - -> IO () -render nm cbl = do - zt <- getZonedTime - IO.hSetBinaryMode IO.stdout False - IO.hSetEncoding IO.stdout IO.utf8 - putStr $ renderString nm zt Paths_cartel.version cbl - diff --git a/lib/Cartel/Types.hs b/lib/Cartel/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Cartel/Types.hs @@ -0,0 +1,13 @@ +module Cartel.Types where + +-- | A non-empty string. This string should never be empty. It is +-- used where, for example, a field in a Cabal file is required to +-- have a value and that value cannot be empty. In contrast, Cartel +-- uses an ordinary 'String' for values that can be empty. +-- +-- This is only a type synonym, so nothing in the type system enforces +-- that these strings must be non-empty. Typically though, Cabal will +-- give you grief about the file that Cartel generates if you used an +-- empty value for a 'NonEmptyString'. +type NonEmptyString = String + diff --git a/lib/Cartel/Version.hs b/lib/Cartel/Version.hs new file mode 100644 --- /dev/null +++ b/lib/Cartel/Version.hs @@ -0,0 +1,14 @@ +-- | The current version for the Cartel library. Having this in a +-- separate module allows for the "Cartel.GenCartelCabal" module to +-- exist. Without this module, I'd have to rely on the @Paths_cartel@ +-- module to exist, which introduces some nasty bootstrapping issues +-- for "Cartel.GenCartelCabal" or, alternatively, some nasty circular +-- dependency issues if this value were included directly into +-- "Cartel.GenCartelCabal". + +module Cartel.Version where + +import Data.Word + +version :: [Word] +version = [0,12,0,0] diff --git a/minimum-versions.txt b/minimum-versions.txt deleted file mode 100644 --- a/minimum-versions.txt +++ /dev/null @@ -1,38 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the minimum versions given in the .cabal file. -Tested as of: 2014-05-30 16:15:53.772569 UTC -Path to compiler: ghc-7.4.1 -Compiler description: 7.4.1 - -/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d: - Cabal-1.14.0 - array-0.4.0.0 - base-4.5.0.0 - bin-package-db-0.0.0.0 - binary-0.5.1.0 - bytestring-0.9.2.1 - containers-0.4.2.1 - deepseq-1.3.0.0 - directory-1.1.0.2 - extensible-exceptions-0.1.1.4 - filepath-1.3.0.0 - (ghc-7.4.1) - ghc-prim-0.2.0.0 - (haskell2010-1.1.0.1) - (haskell98-2.0.0.1) - hoopl-3.8.7.3 - hpc-0.5.1.1 - integer-gmp-0.4.0.0 - old-locale-1.0.0.4 - old-time-1.1.0.0 - pretty-1.1.1.0 - process-1.1.0.1 - rts-1.0 - template-haskell-2.7.0.0 - time-1.4 - unix-2.5.1.0 - -/home/massysett/cartel/sunlight-11214/db: - cartel-0.10.0.0 - diff --git a/tests/Cartel/Generators.hs b/tests/Cartel/Generators.hs new file mode 100644 --- /dev/null +++ b/tests/Cartel/Generators.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Cartel.Generators where + +import Cartel +import Cartel.Betsy +import Control.Applicative +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import System.Random (StdGen, random, randomR, Random(..), mkStdGen) +import Control.Monad.Trans.Reader +import Control.Monad + +type Gen = ReaderT Word (Betsy (State StdGen)) + +class Arbitrary a where + arbitrary :: Gen a + +getSize :: Gen Word +getSize = ask + +resize :: Word -> Gen a -> Gen a +resize w = withReaderT (const w) + +getStdGen :: Gen StdGen +getStdGen = lift . lift $ get + +setStdGen :: StdGen -> Gen () +setStdGen = lift . lift . put + +choose :: Random a => (a, a) -> Gen a +choose pair = do + g <- getStdGen + let (r, g') = randomR pair g + setStdGen g' + return r + +chooseDefault :: Random a => Gen a +chooseDefault = do + g <- getStdGen + let (r, g') = random g + setStdGen g' + return r + +frequency :: [(Int, Gen a)] -> Gen a +frequency [] = error "frequency used with empty list" +frequency xs0 = choose (1, tot) >>= (`pick` xs0) + where + tot = sum (map fst xs0) + pick n ((k, x):xs) + | n <= k = x + | otherwise = pick (n - k) xs + pick _ _ = error "pick used with empty list" + +elements :: [a] -> Gen a +elements [] = error "elements used with empty list" +elements xs = (xs !!) `fmap` choose (0, length xs - 1) + +oneOf :: [Gen a] -> Gen a +oneOf = join . elements + +instance Arbitrary Bool where + arbitrary = chooseDefault + +instance Arbitrary Word where + arbitrary = choose (0, 255) + +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = frequency [(3, fmap Just arbitrary), (1, return Nothing)] + +instance Arbitrary a => Arbitrary [a] where + arbitrary = do + sz <- getSize + c <- choose (0, sz) + replicateM (fromIntegral c) arbitrary + +instance Arbitrary Char where + arbitrary = choose ('a', 'z') + +genNonEmptyString :: Gen NonEmptyString +genNonEmptyString = liftM2 (:) arbitrary (resize 5 arbitrary) + +instance Arbitrary Vcs where + arbitrary = oneOf $ fmap cvs genNonEmptyString + : map return [ darcs, git, svn, mercurial, + bazaar, archVcs, monotone] + +instance Arbitrary RepoKind where + arbitrary = elements [repoHead, repoThis] + +instance Arbitrary Repository where + arbitrary = Repository <$> arbitrary <*> arbitrary <*> arbitrary + <*> genNonEmptyString <*> arbitrary <*> arbitrary + +listOf :: Gen a -> Gen [a] +listOf g = do + sz <- getSize + len <- choose (0, sz) + replicateM (fromIntegral len) g + +genNonEmptyList :: Gen a -> Gen [a] +genNonEmptyList g = liftM2 (:) g (listOf g) + +genVersion :: Gen Version +genVersion = resize 3 (genNonEmptyList (choose (0, 99))) + +instance Arbitrary Constraint where + arbitrary = do + sz <- getSize + lvls <- choose (0, sz) + go lvls + where + go lvl | lvl == 0 = oneOf + [ fmap lt genVersion + , fmap gt genVersion + , fmap eq genVersion + , return anyVersion + ] + | otherwise = do + l <- next + r <- next + op <- elements [ (&&&), (|||) ] + return $ l `op` r + where + next = choose (0, lvl - 1) >>= go + +instance Arbitrary Compiler where + arbitrary = elements [ ghc, nhc, yhc, hugs, helium, jhc, lhc ] + +instance Arbitrary Condition where + arbitrary = do + sz <- getSize + lvls <- choose (0, sz) + goCondition lvls + +goCondition :: Word -> Gen Condition +goCondition lvl + | lvl == 0 = lift currentFlags >>= lowest + | otherwise = upper + where + lowest [] = nonFlagLevel + lowest xs = elements (fmap fst xs) >>= withFlagLevel + nonFlagLevel = oneOf [ fmap system genNonEmptyString + , fmap arch genNonEmptyString + , liftM2 impl arbitrary arbitrary + , return true + , return false + ] + withFlagLevel fl = frequency + [ (2, nonFlagLevel), (1, return $ flag fl)] + upper = frequency [(2, binary), (1, inverted)] + where + next = choose (0, lvl - 1) >>= goCondition + inverted = fmap invert next + binary = do + op <- elements [(&&&), (|||)] + liftM2 op next next + +genCondBlock :: (Arbitrary a, HasBuildInfo a) => Gen a +genCondBlock = liftM3 condBlock arbitrary + (liftM2 (,) arbitrary arbitrary) arbitrary + +instance Arbitrary Package where + arbitrary = liftM2 package genNonEmptyString arbitrary + +genBuildInfo :: HasBuildInfo a => Gen a +genBuildInfo = oneOf + [ return haskell98 + , return haskell2010 + , fmap buildDepends arbitrary + , fmap otherModules neslist + , fmap hsSourceDirs neslist + , fmap extensions neslist + , fmap buildTools (genNonEmptyList arbitrary) + , fmap buildable arbitrary + , fmap ghcOptions neslist + , fmap ghcProfOptions neslist + , fmap ghcSharedOptions neslist + , fmap hugsOptions neslist + , fmap nhc98Options neslist + , fmap includes neslist + , fmap installIncludes neslist + , fmap includeDirs neslist + , fmap cSources neslist + , fmap extraLibraries neslist + , fmap ccOptions neslist + , fmap cppOptions neslist + , fmap ldOptions neslist + , fmap pkgConfigDepends (genNonEmptyList arbitrary) + , fmap frameworks neslist + ] + where + neslist = genNonEmptyList genNonEmptyString + +genMainIs :: BuildsExe a => Gen a +genMainIs = fmap mainIs genNonEmptyString + +instance Arbitrary FlagOpts where + arbitrary = liftM3 FlagOpts arbitrary arbitrary arbitrary + +addFlagsToState + :: Word + -- ^ How many flags? + -> Gen () +addFlagsToState nFlags = do + let mkf = do + nm <- genNonEmptyString + opts <- arbitrary + _ <- lift (makeFlag nm opts) + return () + _ <- replicateM (fromIntegral nFlags) mkf + return () + +downsize :: Gen a -> Gen a +downsize g = do + sz <- getSize + resize (sz - 1) g + +instance Arbitrary LibraryField where + arbitrary = getSize >>= f + where + nonNestGens = + [ (6, genBuildInfo) + , (1, fmap exposed arbitrary) + , (1, fmap exposedModules (genNonEmptyList genNonEmptyString)) + ] + f sz | sz == 0 = nonNest + | otherwise = nest + where + nonNest = frequency nonNestGens + nest = downsize . frequency $ + (1, genCondBlock) : nonNestGens + + +instance Arbitrary ExecutableField where + arbitrary = getSize >>= f + where + nonNestGens = + [ (6, genBuildInfo) + , (1, genMainIs) + ] + nestGens = (1, genCondBlock) : nonNestGens + f sz | sz == 0 = frequency nonNestGens + | otherwise = downsize $ frequency nestGens + +instance Arbitrary TestSuiteField where + arbitrary = getSize >>= f + where + nonNestGens = + [ (7, genBuildInfo) + , (1, fmap testModule genNonEmptyString) + , (1, pure exitcodeStdio) + , (1, pure detailed) + , (1, genMainIs) + ] + nestGens = (1, genCondBlock) : nonNestGens + f sz | sz == 0 = frequency nonNestGens + | otherwise = downsize $ frequency nestGens + +instance Arbitrary BenchmarkField where + arbitrary = getSize >>= f + where + nonNest = + [ (6, genBuildInfo) + , (1, return exitcodeStdio) + ] + nest = (1, genCondBlock) : nonNest + f sz | sz == 0 = frequency nonNest + | otherwise = downsize $ frequency nest + +instance Arbitrary BuildType where + arbitrary = elements [simple, configure, make, custom] + +instance Arbitrary License where + arbitrary = elements [ gpl, agpl, lgpl, bsd2, bsd3, bsd4, mit, mpl, + apache, publicDomain, allRightsReserved, + otherLicense ] + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where + arbitrary = liftM2 (,) arbitrary arbitrary + +instance Arbitrary Properties where + arbitrary = Properties + <$> genNonEmptyString -- name + <*> genVersion -- version + <*> arbitrary -- cabalVersion + <*> arbitrary -- buildType + <*> arbitrary -- license + <*> arbitrary -- licenseFile + <*> listOf genNonEmptyString -- licenseFiles + <*> arbitrary -- copyright + <*> arbitrary -- author + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- bugReports + <*> arbitrary + <*> arbitrary + <*> arbitrary -- description + <*> arbitrary + <*> arbitrary + <*> listOf genNonEmptyString -- dataFiles + <*> arbitrary + <*> listOf genNonEmptyString + <*> listOf genNonEmptyString + <*> listOf genNonEmptyString -- extraTmpFiles + +instance Arbitrary Section where + arbitrary = frequency [(3, nonRepo), (1, repo)] + where + nonRepo = oneOf + [ liftM2 executable genNonEmptyString arbitrary + , liftM2 testSuite genNonEmptyString arbitrary + , liftM2 benchmark genNonEmptyString arbitrary + ] + repo = fmap repository arbitrary + +instance Arbitrary Cabal where + arbitrary = do + sz <- getSize + nFlags <- choose (0, sz) + addFlagsToState nFlags + liftM3 cabal arbitrary arbitrary arbitrary + +-- | Generates Cabal text given a size parameter and int to generate a +-- seed. Read the function from the bottom up: +-- +-- * generates a random computation in ReaderT +-- +-- * runs the ReaderT with the given size, resulting in a 'Betsy' +-- +-- * renders the 'Betsy', which results in a State computation with +-- the 'StdGen' as the state +-- +-- * runs the State computation with an initialized generator, +-- resulting in a pair (a, s), where @s@ is the resulting state and +-- @a@ is an Either +-- +-- * gets the Either, discards the resulting state, resulting in an +-- @Either Error String@ +-- +-- * transforms the @Error@ to a string +genCabalText + :: Word + -- ^ Size + -> Int + -- ^ Random seed + -> Either String String + -- ^ Either an error message, or the Cabal text. +genCabalText sz sd + = either (Left . renderIndented 0) (Right . id) + . fst + . flip runState (mkStdGen sd) + . renderBetsy + . flip runReaderT sz + $ arbitrary + +genResult + :: Gen a + -- ^ Generator + -> Word + -- ^ How many flags? + -> Word + -- ^ Size + -> Int + -- ^ Random seed + -> Either String a +genResult gen nFlags sz sd + = either (Left . renderIndented 0) (Right . fst) + . fst + . flip runState (mkStdGen sd) + . runBetsy + . flip runReaderT sz + $ (addFlagsToState nFlags >> gen) diff --git a/tests/Cartel/Properties.hs b/tests/Cartel/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Cartel/Properties.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- | Cartel properties. For the time being, most (maybe all) of these +-- properties test the generators, rather than Cartel itself. I had +-- to debug generators that were stuck in an infinite loop. +module Cartel.Properties where + +import Cartel +import Control.Monad +import Test.QuickCheck +import qualified Cartel.Generators as G + +seconds :: Int -> Int +seconds = (* 10 ^ (6 :: Int)) + +newtype Little = Little Word + deriving (Eq, Ord, Show) + +instance Arbitrary Little where + arbitrary = sized f + where + f sz = fmap Little (choose (0, min (fromIntegral sz) 10)) + +completesInSecs + :: Show a + => Int + -- ^ How many seconds + -> G.Gen a + -> Little + -- ^ How many flags + -> Little + -- ^ Size + -> Int + -- ^ Seed + -> Property +completesInSecs time gen (Little nFlags) (Little sz) sd + = within (seconds time) $ + length (show (G.genResult gen nFlags sz sd)) >= 0 + +prop_vcsCompletesInSecs = completesInSecs 10 (G.arbitrary :: G.Gen Vcs) + +prop_constraintCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Constraint) + +mainIsCompletesInSecs a = completesInSecs 10 (G.genMainIs `asTypeOf` a) + +prop_conditionCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Condition) + +buildInfoCompletesInSecs a = completesInSecs 10 (G.genBuildInfo `asTypeOf` a) + +-- ExecutableField contents + +prop_buildInfoExeCompletesInSecs = buildInfoCompletesInSecs + (undefined :: G.Gen ExecutableField) + +prop_condBlockExeCompletesInSecs = completesInSecs 10 + (G.genCondBlock :: G.Gen ExecutableField) + +prop_exeMainIsCompletesInSecs = mainIsCompletesInSecs + (undefined :: G.Gen ExecutableField) + +prop_cabalCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Cabal) + +prop_propertiesCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Properties) + +prop_repositoryCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Repository) + +prop_sectionCompletesInSecs = completesInSecs 10 + (G.arbitrary :: G.Gen Section) + +prop_executableCompletesInSecs = completesInSecs 10 + (liftM2 executable G.genNonEmptyString G.arbitrary) + +prop_benchmarkCompletesInSecs = completesInSecs 10 + (liftM2 benchmark G.genNonEmptyString G.arbitrary) + +prop_testSuiteCompletesInSecs = completesInSecs 10 + (liftM2 testSuite G.genNonEmptyString G.arbitrary) + diff --git a/tests/Decrees.hs b/tests/Decrees.hs new file mode 100644 --- /dev/null +++ b/tests/Decrees.hs @@ -0,0 +1,26 @@ +-- | This module generated by the Quickpull package. +-- Quickpull is available at: +-- + +module Decrees where + +import Quickpull +import qualified Cartel.Properties + +decrees :: [Decree] +decrees = + + [ Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 40, qName = "prop_vcsCompletesInSecs"} ) ( Single Cartel.Properties.prop_vcsCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 42, qName = "prop_constraintCompletesInSecs"} ) ( Single Cartel.Properties.prop_constraintCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 47, qName = "prop_conditionCompletesInSecs"} ) ( Single Cartel.Properties.prop_conditionCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 54, qName = "prop_buildInfoExeCompletesInSecs"} ) ( Single Cartel.Properties.prop_buildInfoExeCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 57, qName = "prop_condBlockExeCompletesInSecs"} ) ( Single Cartel.Properties.prop_condBlockExeCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 60, qName = "prop_exeMainIsCompletesInSecs"} ) ( Single Cartel.Properties.prop_exeMainIsCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 63, qName = "prop_cabalCompletesInSecs"} ) ( Single Cartel.Properties.prop_cabalCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 66, qName = "prop_propertiesCompletesInSecs"} ) ( Single Cartel.Properties.prop_propertiesCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 69, qName = "prop_repositoryCompletesInSecs"} ) ( Single Cartel.Properties.prop_repositoryCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 72, qName = "prop_sectionCompletesInSecs"} ) ( Single Cartel.Properties.prop_sectionCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 75, qName = "prop_executableCompletesInSecs"} ) ( Single Cartel.Properties.prop_executableCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 78, qName = "prop_benchmarkCompletesInSecs"} ) ( Single Cartel.Properties.prop_benchmarkCompletesInSecs ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Cartel/Properties.hs", modName = ["Cartel","Properties"]}, linenum = 81, qName = "prop_testSuiteCompletesInSecs"} ) ( Single Cartel.Properties.prop_testSuiteCompletesInSecs ) + ] diff --git a/tests/cartel-properties.hs b/tests/cartel-properties.hs new file mode 100644 --- /dev/null +++ b/tests/cartel-properties.hs @@ -0,0 +1,7 @@ +module Main where + +import Quickpull +import Decrees + +main :: IO () +main = defaultMain decrees diff --git a/tests/cartel-visual-test.hs b/tests/cartel-visual-test.hs new file mode 100644 --- /dev/null +++ b/tests/cartel-visual-test.hs @@ -0,0 +1,81 @@ +-- | Generates random Cabal text. The program takes two arguments. +-- The first is a size parameter. This should be a non-negative +-- integer. Bigger sizes will result in bigger results generated. +-- The second argument is the random seed. It should be any integer. +-- Different seeds should generate different results. +module Main where + +import Data.Word +import Cartel.Generators +import System.Environment +import Data.Either +import Text.Read (readMaybe) +import System.Random +import System.Exit +import qualified System.IO as IO +import Multiarg + +maxSize :: Word +maxSize = 10 + +help :: (String -> String) +help pn = unlines + [ pn ++ " - generates random Cabal text." + , "Options:" + , " --size INT - runs generator with the given size." + , " INT must be non-negative. Larger INT will" + , " result in larger results." + , " --seed INT - runs generator with the given seed." + , " Without these options, a random seed is chosen, and" + , " a random size between 0 and " ++ show maxSize ++ " is chosen." + ] + +opts :: [OptSpec (IO (Either Word Int))] +opts = + [ optSpec "" ["size"] (OneArg (fmap Left . readVal)) + , optSpec "" ["seed"] (OneArg (fmap Right . readVal)) + ] + +failOnPosArg :: IO a +failOnPosArg = do + pn <- getProgName + fail $ pn ++ " does not accept positional arguments." + +finalOptions :: [Either Word Int] -> IO (Word, Int) +finalOptions ls = do + let (ws, is) = partitionEithers ls + sz <- case safeLast ws of + Nothing -> randomRIO (0, maxSize) + Just x -> return x + sd <- case safeLast is of + Nothing -> randomIO + Just x -> return x + return (sz, sd) + +safeLast :: [a] -> Maybe a +safeLast xs + | null xs = Nothing + | otherwise = Just . last $ xs + +readVal :: Read a => String -> IO a +readVal s = maybe (fail $ "could not read string: " ++ s) return + . readMaybe $ s + +main :: IO () +main = do + eithersActs <- parseCommandLine help opts (const failOnPosArg) + eithers <- sequence eithersActs + (sz, sd) <- finalOptions eithers + case genCabalText sz sd of + Left e -> do + IO.hPutStrLn IO.stderr "could not generate Cabal text." + IO.hPutStr IO.stderr e + exitFailure + Right g -> printHeader sz sd >> putStr g >> exitSuccess + +printHeader :: Word -> Int -> IO () +printHeader sz sd = putStr $ unlines + [ replicate 50 '-' + , "-- below - size: " ++ show sz ++ " seed: " ++ show sd + , replicate 50 '-' + ]