cartel 0.12.0.2 → 0.14.0.0

raw patch · 9 files changed

+460/−385 lines, 9 filesdep ~QuickCheckdep ~basedep ~directoryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base, directory, filepath, multiarg, quickpull, random, time, transformers

API changes (from Hackage documentation)

Files

• cartel.cabal +52/−51
• lib/Cartel.hs +70/−65
• lib/Cartel/Ast.hs +20/−17
• lib/Cartel/Betsy.hs +1/−0
• lib/Cartel/Betsy/Internal.hs +12/−14
• lib/Cartel/Render.hs +275/−220
• lib/Cartel/Version.hs +1/−1
• tests/Cartel/Generators.hs +28/−17
• tests/Cartel/Properties.hs +1/−0

@@ -3,10 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: GenCartelCabal.hs--- Generated on: 2015-01-17 23:17:40.719595 EST--- Cartel library version: 0.12.0.2+-- Generated on: 2015-01-27 14:23:00.800469 EST+-- Cartel library version: 0.14.0.0+ name: cartel-version: 0.12.0.2+version: 0.14.0.0 cabal-version: >= 1.16 license: BSD3 license-file: LICENSE@@ -27,32 +28,32 @@   See the documentation in the "Cartel" module for details. category: Distribution tested-with:-    GHC == 7.6.3-  , GHC == 7.8.2+  GHC == 7.6.3+  GHC == 7.8.2 extra-source-files:-    README.md+  README.md  Library   exposed-modules:-      Cartel-    , Cartel.Ast-    , Cartel.Betsy-    , Cartel.Betsy.Internal-    , Cartel.GenCartelCabal-    , Cartel.Render-    , Cartel.Types-    , Cartel.Version+    Cartel+    Cartel.Ast+    Cartel.Betsy+    Cartel.Betsy.Internal+    Cartel.GenCartelCabal+    Cartel.Render+    Cartel.Types+    Cartel.Version   default-language: Haskell2010   ghc-options:-      -Wall+    -Wall   hs-source-dirs:-      lib+    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.3.0.0 || == 0.3.0.0) && < 0.5)+      base >= 4.5.0.0 && < 4.8+    , directory >= 1.1.0.2 && < 1.3+    , filepath >= 1.3.0.0 && < 1.4+    , time >= 1.4 && < 1.6+    , transformers >= 0.3.0.0 && < 0.5  source-repository head   type: git@@ -62,26 +63,26 @@   if flag(visual)     buildable: True     other-modules:-        Cartel.Generators-      , Cartel.Properties-      , Decrees+      Cartel.Generators+      Cartel.Properties+      Decrees     hs-source-dirs:-        tests+      tests     build-depends:-        multiarg ((> 0.30.0.0 || == 0.30.0.0) && < 0.31)-      , QuickCheck ((> 2.7 || == 2.7) && < 2.8)-      , random ((> 1.0.1.1 || == 1.0.1.1) && < 1.2)-      , quickpull ((> 0.4.0.0 || == 0.4.0.0) && < 0.5)+        multiarg >= 0.30.0.0 && < 0.31+      , QuickCheck >= 2.7 && < 2.8+      , random >= 1.0.1.1 && < 1.2+      , quickpull >= 0.4.0.0 && < 0.5     ghc-options:-        -Wall+      -Wall     hs-source-dirs:-        lib+      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.3.0.0 || == 0.3.0.0) && < 0.5)+        base >= 4.5.0.0 && < 4.8+      , directory >= 1.1.0.2 && < 1.3+      , filepath >= 1.3.0.0 && < 1.4+      , time >= 1.4 && < 1.6+      , transformers >= 0.3.0.0 && < 0.5   else     buildable: False   default-language: Haskell2010@@ -90,26 +91,26 @@ Test-Suite cartel-properties   default-language: Haskell2010   other-modules:-      Cartel.Generators-    , Cartel.Properties-    , Decrees+    Cartel.Generators+    Cartel.Properties+    Decrees   hs-source-dirs:-      tests+    tests   build-depends:-      multiarg ((> 0.30.0.0 || == 0.30.0.0) && < 0.31)-    , QuickCheck ((> 2.7 || == 2.7) && < 2.8)-    , random ((> 1.0.1.1 || == 1.0.1.1) && < 1.2)-    , quickpull ((> 0.4.0.0 || == 0.4.0.0) && < 0.5)+      multiarg >= 0.30.0.0 && < 0.31+    , QuickCheck >= 2.7 && < 2.8+    , random >= 1.0.1.1 && < 1.2+    , quickpull >= 0.4.0.0 && < 0.5   ghc-options:-      -Wall+    -Wall   hs-source-dirs:-      lib+    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.3.0.0 || == 0.3.0.0) && < 0.5)+      base >= 4.5.0.0 && < 4.8+    , directory >= 1.1.0.2 && < 1.3+    , filepath >= 1.3.0.0 && < 1.4+    , time >= 1.4 && < 1.6+    , transformers >= 0.3.0.0 && < 0.5   type: exitcode-stdio-1.0   main-is: cartel-properties.hs 

@@ -159,6 +159,7 @@   -- ** Flags   , FlagName   , FlagOpts(..)+  , Flag(..)   , makeFlag   , currentFlags @@ -225,59 +226,29 @@   , 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+  , defaultMainWithHeader    ) where  -- # begin imports  import Cartel.Ast+import Cartel.Betsy import Cartel.Render-import qualified System.IO as IO-import Data.Time+import Cartel.Types import qualified Cartel.Version+import Control.Applicative import Data.List (intersperse)-import System.Exit (exitFailure, exitSuccess)-import System.Environment (getProgName)+import Data.Time import Data.Word-import Control.Monad.IO.Class-import Cartel.Betsy-import Cartel.Types+import System.Environment (getProgName)+import System.Exit (exitFailure, exitSuccess)+import qualified System.IO as IO  -- # 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@@ -304,24 +275,51 @@       . map show       $ Cartel.Version.version +-- | Generic header to prepend to Cabal files.+genericHeader :: IO String+genericHeader = header <$> getProgName <*> getZonedTime --- | 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 +-- | Like 'defaultMain' but allows you to specify what header to+-- prepend to the output (if any).+defaultMainWithHeader +  :: (Cabal -> IO String)+  -- ^ Function that generates a header.  This header will be+  -- prepended to the resulting Cabal file; for instance, you might+  -- place comments in this header.  This function is applied to the+  -- resulting Cabal record.  For no header, just use+  -- @const (return \"\")@ here.+  --+  -- The 'Cabal' type is not exported from this module to keep the+  -- number of exported bindings down; you can @import@ it from+  -- @Cartel.Ast@.++  -> Betsy IO (Properties, [LibraryField], [Section])+  -- ^ Computation that creates the package information.  'Betsy'+  -- creates 'Flag's.  The 'Betsy' type constructor is appled to 'IO'+  -- so that functions such as 'modules' can do IO to query the file+  -- system.++  -> IO ()+  -- ^ Prints Cabal file to standard output if there were no errors+  -- along the way; otherwise, prints a message to standard error and+  -- exits unsuccessfully.++defaultMainWithHeader mkHdr btsy = do+  ei <- runBetsy btsy+  ((prop, libs, secs), flgs) <- case ei of+    Left e -> do+      IO.hPutStr IO.stderr . renderNoIndent $ e+      exitFailure+    Right g -> return g+  let cbl = Cabal prop libs secs flgs+  hdr <- mkHdr cbl+  IO.hSetBinaryMode IO.stdout False+  IO.hSetEncoding IO.stdout IO.utf8+  putStr . vsep $ [hdr, renderNoIndent cbl]+  exitSuccess+ -- | 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'.@@ -330,18 +328,25 @@ -- 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'.+-- Output will always be UTF-8, consistent with Cabal's requirements.+--+-- Includes a header showing that the Cabal file was auto-generated+-- and the program name that generated the Cabal file, along with when+-- it was generated.  This gives a clue to readers who see a Cabal+-- file in the distributed tarball but who would get confused when there+-- isn't one in the version controlled sources.  To omit the header,+-- use 'defaultMainWithHeader'. defaultMain+   :: Betsy IO (Properties, [LibraryField], [Section])+  -- ^ Computation that creates the package information.  'Betsy'+  -- creates 'Flag's.  The 'Betsy' type constructor is appled to 'IO'+  -- so that functions such as 'modules' can do IO to query the file+  -- system.+   -> 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+  -- ^ Prints Cabal file to standard output if there were no errors+  -- along the way; otherwise, prints a message to standard error and+  -- exits unsuccessfully.++defaultMain = defaultMainWithHeader (const genericHeader)

@@ -162,14 +162,21 @@   | And   deriving (Eq, Ord, Show) +-- | Whether @or equal to@ comparisions are also true.+newtype OrEqualTo = OrEqualTo Bool+  deriving (Eq, Ord, Show)++-- | Expresses comparisons between versions.+data VersionComp+  = LessThan OrEqualTo+  | GreaterThan OrEqualTo+  | EqualTo+  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))+-- more complex dependency relationships. data ConstrTree-  = Leaf Ordering Version+  = Leaf VersionComp Version   | Branch Logical ConstrTree ConstrTree   deriving (Eq, Ord, Show) @@ -237,23 +244,23 @@  -- | Less than lt :: Version -> Constraint-lt = Constrained . Leaf LT+lt = Constrained . Leaf (LessThan (OrEqualTo False))  -- | Greater than gt :: Version -> Constraint-gt = Constrained . Leaf GT+gt = Constrained . Leaf (GreaterThan (OrEqualTo False))  -- | Equal to eq :: Version -> Constraint-eq = Constrained . Leaf EQ+eq = Constrained . Leaf EqualTo  -- | Less than or equal to ltEq :: Version -> Constraint-ltEq v = lt v ||| eq v+ltEq = Constrained . Leaf (LessThan (OrEqualTo True))  -- | Greater than or equal to gtEq :: Version -> Constraint-gtEq v = gt v ||| eq v+gtEq = Constrained . Leaf (GreaterThan (OrEqualTo True))  -- | Matches any version at all (in a Cabal file, this is represented -- as an empty string).@@ -1198,12 +1205,8 @@   { properties :: Properties   , library :: [LibraryField]   , sections :: [Section]+  , flags :: [Flag]   } 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 [] []+  blank = Cabal blank [] [] []

@@ -5,6 +5,7 @@   , flagNameHead   , flagNameTail   , FlagOpts(..)+  , Flag(..)   , Betsy   , Error(..)   , runBetsy

@@ -27,10 +27,6 @@       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'.@@ -42,7 +38,7 @@ -- 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)))+newtype Betsy m a = Betsy ([Flag] -> m (Either Error (a, [Flag])))  instance Monad m => Monad (Betsy m) where   return a = Betsy $ \s -> return (Right (a, s))@@ -74,6 +70,10 @@  -- ** Flags +-- | The name of a flag, paired with its options.+data Flag = Flag FlagName FlagOpts+  deriving (Eq, Ord, Show)+ -- | Options for flags, except for the flag's name. data FlagOpts = FlagOpts   { flagDescription :: String@@ -104,29 +104,27 @@   -> 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 $+makeFlag nes opts = Betsy $ \fls -> pure $   case nes of     [] -> Left EmptyFlagName     x:xs ->       let nm = FlagName x xs-      in case lookup nm fls of+      in case lookup nm . map (\(Flag n v) -> (n, v)) $ fls of           Nothing ->-            let st' = State ((nm, opts) : fls)+            let st' = Flag nm opts : fls             in Right (nm, st')           Just _ -> Left (DuplicateFlag nm)  runBetsy   :: Functor m   => Betsy m a-  -> m (Either Error (a, [(FlagName, FlagOpts)]))+  -> m (Either Error (a, [Flag]))   -- ^ 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)+runBetsy (Betsy f) = f []   -- | 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))+currentFlags :: Applicative f => Betsy f [Flag]+currentFlags = Betsy $ \ls -> pure (Right (ls, ls))

@@ -3,10 +3,13 @@ -- pretty-printer. module Cartel.Render where -import Data.Word-import Cartel.Betsy import Cartel.Ast+import Cartel.Betsy+import Control.Applicative+import Control.Monad.Trans.Reader+import Data.Char (isLetter, isDigit) import Data.List (intersperse)+import Data.Word  -- | Separate two strings with a space, but only if both strings are -- not empty.@@ -29,69 +32,98 @@ 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"---- | 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) ' ' ++ render s ++ "\n"-    lineRest s = replicate (i * indentAmt) ' '-      ++ ", " ++ render s ++ "\n"- labeled-  :: Renderable a-  => Int-  -- ^ Indentation-  -> String+  :: String   -- ^ Label-  -> a-  -- ^ Text   -> String-  -- ^ Result, with a newline.  Empty if the text to show is also-  -- empty.-labeled i l t-  | null txt = ""-  | otherwise = indent i (l ++ ": " ++ txt)-  where-    txt = render t--labeledList-  :: Renderable a-  => Int-  -- ^ Indentation+  -- ^ Value   -> String+  -- ^ Empty if value is empty; otherwise, the label with a colon and+  -- space appended, and the value+labeled lbl val+  | null val = ""+  | otherwise = lbl ++ ": " ++ val++labeledIndented+  :: String   -- ^ Label-  -> [a]-  -- ^ List   -> String-  -- ^ Result, with newlines.  Empty if the list is empty.-labeledList i l ts-  | null ts = ""-  | otherwise = indent i (l ++ ":") ++ indentList (i + 1) ts+  -- ^ Value+  -> Reader Level String+  -- ^ Empty if value is empty; otherwise, the label with a colon and+  -- space appended, and the value, and a newline+labeledIndented lbl val+  | null val = return ""+  | otherwise = indent (lbl ++ ": " ++ val ++ "\n") --- | Render an item.  The rendered text shall contain no newlines.-class Renderable a where-  render :: a -> String+-- | Indentation level+type Level = Int -instance Renderable String where-  render = id+addLevel :: Reader Level a -> Reader Level a+addLevel = withReader succ -instance Renderable a => Renderable (Maybe a) where-  render = maybe "" render+indent :: String -> Reader Level String+indent s = fmap fmt ask+  where+    fmt lvl = replicate (lvl * indentAmt) ' ' ++ s +-- Rendering Lists+--+-- General steps to render lists of items (e.g. build depends,+-- ghc-options, etc):+--+-- 1. Transform list of items into list of String (simply use fmap)+--+-- 2. Prepend comma separators, if applicable+--+-- 3. Prepend indentation, append newlines, concat+--+-- 4. Prepend indented label if result is not empty++-- | Adds comma separators to a list.+commaSeparated :: [String] -> [String]+commaSeparated [] = []+commaSeparated (x:xs)+  = (replicate 2 ' ' ++ x) : map (", " ++) xs++-- | Indents list, adds newlines, and concats.+indentConcat+  :: [String]+  -> Reader Level String+indentConcat ss = do+  ss' <- mapM indent ss+  return $ concatMap (++ "\n") ss'++labeledList+  :: String+  -- ^ Label+  -> [String]+  -- ^ List of items to show; if empty, return an empty string+  -> Reader Level String+labeledList _ [] = return ""+labeledList lbl xs+  = (++)+  <$> indent (lbl ++ ":\n")+  <*> addLevel (indentConcat xs)++-- | Renders a string using 'show', but only if it is both non-empty+-- and contains characters that might be problematic.  For now,+-- \"might be problematic\" simply means any character that is either+-- above Unicode code point 7F or is not a letter, digit, hyphen,+-- period, or underscore.+--+-- If the string is empty, or if it contains only non-problematic+-- characters, returns the string as-is.+escaper :: String -> String+escaper s+  | null s = s+  | any ((> 0x7f) . fromEnum) s = show s+  | all good s = s+  | otherwise = show s+  where+    good x = any ($ x)+      [ isLetter, isDigit, (== '-'), (== '_'), (== '.') ]+ -- | 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@@ -100,11 +132,21 @@ -- -- If there are no lines to indent, return an empty string. class RenderableIndented a where-  renderIndented :: Int -> a -> String+  renderIndented :: a -> Reader Level String +renderNoIndent :: RenderableIndented a => a -> String+renderNoIndent = flip runReader 0 . renderIndented ++-- | Render an item.  The rendered text shall contain no newlines.+class Renderable a where+  render :: a -> String++instance Renderable a => Renderable (Maybe a) where+  render = maybe "" render+ instance RenderableIndented Error where-  renderIndented i e = concatMap (indent i) $+  renderIndented e = fmap concat . mapM indent $     "Error while attempting to generate Cabal file from Cartel source."     : case e of         DuplicateFlag nm ->@@ -121,10 +163,13 @@ instance Renderable Compiler where   render = show -instance Renderable Ordering where-  render LT = "<"-  render GT = ">"-  render EQ = "=="+instance Renderable VersionComp where+  render c = case c of+    LessThan (OrEqualTo True) -> "<="+    GreaterThan (OrEqualTo True) -> ">="+    LessThan (OrEqualTo False) -> "<"+    GreaterThan (OrEqualTo False) -> ">"+    EqualTo -> "=="  instance Renderable Version where   render = concat . intersperse "." . map show@@ -138,24 +183,21 @@   render And = "&&"  instance Renderable ConstrTree where-  render (Leaf o v) = render o <+> render v-  render (Branch c l r) = "(" ++ render l-    <+> render c <+> render r ++ ")"--instance Renderable (Word, Word) where-  render (a, b) = ">= " ++ show a ++ "." ++ show b+  render = go (0 :: Int)+    where+      go lvl tree = case tree of+        Leaf o v -> render o <+> render v+        Branch c l r -> parens $ next l <+> render c <+> next r+        where+          next = go (succ lvl)+          parens x | lvl == 0 = x+                   | otherwise = '(' : x ++ ")" -newtype Description = Description [String]+data CabalVersion = CabalVersion Word Word   deriving (Eq, Ord, Show) -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+instance Renderable CabalVersion where+  render (CabalVersion a b) = ">= " ++ show a ++ "." ++ show b  instance Renderable (Compiler, Constraint) where   render (cmp, cst) = render cmp <+> render cst@@ -163,18 +205,26 @@ instance Renderable FlagName where   render nm = flagNameHead nm : flagNameTail nm -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 RenderableIndented FlagOpts where+  renderIndented (FlagOpts desc df man) =+    fmap concat . mapM (uncurry labeledIndented)+      $ [ ("description", desc)+        , ("default", render df)+        , ("manual", render man)+        ] -instance RenderableIndented [(FlagName, FlagOpts)] where-  renderIndented i = vsep . map (renderIndented i)+instance RenderableIndented Flag where+  renderIndented (Flag nm opts) =+    (++)+    <$> indent ("Flag " ++ render nm ++ "\n")+    <*> addLevel (renderIndented opts) +newtype Flags = Flags [Flag]+  deriving (Eq, Ord, Show)++instance RenderableIndented Flags where+  renderIndented (Flags fs) = fmap vsep . mapM renderIndented $ fs+ instance Renderable CondLeaf where   render a = case a of     OS s -> "os(" ++ s ++ ")"@@ -202,23 +252,26 @@     Monotone -> "monotone"  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)+  renderIndented r =+    (++)+    <$> indent ("source-repository " ++ render (repoKind r) ++ "\n")+    <*> addLevel (fmap concat . mapM (uncurry labeledIndented) $ fields)     where+      fields =+        [ ("type", (render $ repoVcs r))+        , ("location", (repoLocation r))+        , ("module", mdle)+        , ("branch", (repoBranch r))+        , ("tag", (repoTag r))+        , ("subdir", (repoSubdir r))+        ]       mdle = case repoVcs r of         Just (Cvs s) -> s         _ -> ""-      lbl x = labeled (i + 1) x  instance Renderable Package where  render (Package nm cs)-   = nm <+> render cs+   = escaper nm <+> render cs    instance Renderable Bool where   render = show@@ -226,161 +279,163 @@ instance Renderable DefaultLanguage where   render = show +-- | Contains many lists of items.  Items that might contain spaces or+-- other troublesome characters are rendered quoted.  In particular,+-- this includes filenames.  Items that are highly unlikely to contain+-- troublesome characters (such as compiler options) are not quoted. 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+  renderIndented fld = case fld of+    BuildDepends ls -> renCommas "build-depends" ls+    OtherModules ls -> labeledList "other-modules" ls+    HsSourceDirs ls -> labeledList "hs-source-dirs" (fmap escaper ls)+    Extensions ls -> labeledList "extensions" ls+    BuildTools ls -> renCommas "build-tools" ls+    Buildable b -> labeledIndented "buildable" (render b)+    GHCOptions ls -> labeledList "ghc-options" ls+    GHCProfOptions ls -> labeledList "ghc-prof-options" ls+    GHCSharedOptions ls -> labeledList "ghc-shared-options" ls+    HugsOptions ls -> labeledList "hugs-options" ls+    Nhc98Options ls -> labeledList "nhc98-options" ls+    Includes ls -> labeledList "includes" (fmap escaper ls)+    InstallIncludes ls -> labeledList "install-includes" (fmap escaper ls)+    IncludeDirs ls -> labeledList "include-dirs" (fmap escaper ls)+    CSources ls -> labeledList "c-sources" (fmap escaper ls)+    ExtraLibraries ls -> labeledList "extra-libraries" (fmap escaper ls)+    ExtraLibDirs ls -> labeledList "extra-lib-dirs" (fmap escaper ls)+    CCOptions ls -> labeledList "cc-options" ls+    CPPOptions ls -> labeledList "cpp-options" ls+    LDOptions ls -> labeledList "ld-options" ls+    PkgConfigDepends ls -> renCommas "pkgconfig-depends" ls+    Frameworks ls -> labeledList "frameworks" (fmap escaper ls)+    DefaultLanguage df -> labeledIndented "default-language" (render df)     where-      -- don't do @lst = labeledList i@ - monomorphism restriction-      lst l = labeledList i l-      lbl l = labeled i l+      renCommas lbl ls+        | null ls = return ""+        | otherwise = (++) <$> indent (lbl ++ ":\n")+            <*> addLevel ( indentConcat . commaSeparated+                           . fmap render $ ls) -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  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 ++ ")"+  render = go (0 :: Int)+    where+      go lvl tree = case tree of+        CLeaf c -> render c+        CBranch c l r -> parens $ next l+          <+> render c <+> next r+        CNegate t -> "!(" ++ render t ++ ")"+        where+          next = go (succ lvl)+          parens x | lvl == 0 = x+                   | otherwise = '(' : x ++ ")"  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+  renderIndented (CondBlock cond (y1, ys) nos) = fmap concat . sequence $+    [ indent ("if " ++ render cond ++ "\n")+    , addLevel (renderIndented y1)+    , fmap concat (addLevel (mapM renderIndented ys))+    , if null nos+      then return ""+      else (++) <$> indent "else\n"+                <*> addLevel (fmap concat (mapM renderIndented nos))+    ] +instance RenderableIndented LibraryField where+  renderIndented fld = case fld of+    ExposedModules ls -> labeledList "exposed-modules" ls+    Exposed b -> labeledIndented "exposed" (render b)+    LibConditional b -> renderIndented b+    LibInfo b -> renderIndented b+ 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+  renderIndented fld = case fld of+    ExeConditional b -> renderIndented b+    ExeInfo b -> renderIndented b+    ExeMainIs m -> labeledIndented "main-is" (escaper m)  instance RenderableIndented Executable where-  renderIndented i (Executable nm flds) =-    indent i ("Executable " ++ nm)-    ++ concatMap (renderIndented next) flds-    where-      next = i + 1+  renderIndented (Executable nm flds) = (++)+    <$> indent ("Executable " ++ nm ++ "\n")+    <*> addLevel (fmap concat . mapM renderIndented $ flds)  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+  renderIndented fld = case fld of+    TestConditional c -> renderIndented c+    TestInfo b -> renderIndented b+    TestMainIs m -> labeledIndented "main-is" (escaper m)+    TestSuiteType t -> labeledIndented "type" (render t)+    TestModule m -> labeledIndented "test-module" (escaper m)  instance RenderableIndented TestSuite where-  renderIndented i (TestSuite n flds) =-    indent i ("Test-Suite " ++ n)-    ++ concatMap (renderIndented next) flds-    where-      next = i + 1+  renderIndented (TestSuite n flds) = (++)+    <$> indent ("Test-Suite " ++ n ++ "\n")+    <*> addLevel (fmap concat . mapM renderIndented $ flds)  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+  renderIndented (BenchmarkConditional b) = renderIndented b+  renderIndented (BenchmarkInfo b) = renderIndented b+  renderIndented (BenchmarkMainIs b) = labeledIndented "main-is" (escaper b)+  renderIndented (BenchmarkType b) = labeledIndented "type" (render b)  instance RenderableIndented Benchmark where-  renderIndented i (Benchmark nm flds) =-    indent i ("Benchmark " ++ nm)-    ++ concatMap (renderIndented next) flds-    where-      next = i + 1+  renderIndented (Benchmark nm flds) = (++)+    <$> indent ("Benchmark " ++ nm ++ "\n")+    <*> addLevel (fmap concat . mapM renderIndented $ flds)  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+  renderIndented c = fmap concat . sequence $+    [ labeledIndented "name" (name c)+    , labeledIndented "version" (render (version c))+    , labeledIndented "cabal-version"+        (maybe "" (render . uncurry CabalVersion) . cabalVersion $ c)+    , labeledIndented "license" (maybe "" render . license $ c)+    , labeledIndented "license-file" (escaper $ licenseFile c)+    , labeledList "license-files" . fmap escaper . licenseFiles $ c+    , labeledIndented "build-type" (maybe "" render . buildType $ c)+    , labeledIndented "copyright" (copyright c)+    , labeledIndented "author" (author c)+    , labeledIndented "maintainer" (maintainer c)+    , labeledIndented "stability" (stability c)+    , labeledIndented "homepage" (homepage c)+    , labeledIndented "bug-reports" (bugReports c)+    , labeledIndented "package-url" (packageUrl c)+    , labeledIndented "synopsis" (synopsis c)+    , labeledList "description"+        . fmap (\x -> if null x then "." else x)+        . description $ c+    , labeledIndented "category" (category c)+    , labeledList "tested-with" (fmap render . testedWith $ c)+    , labeledList "data-files" (map escaper . dataFiles $ c)+    , labeledIndented "data-dir" (escaper $ dataDir c)+    , labeledList "extra-source-files" (fmap escaper $ extraSourceFiles c)+    , labeledList "extra-doc-files" (fmap escaper $ extraDocFiles c)+    , labeledList "extra-tmp-files" (fmap escaper $ extraTmpFiles c)+    ] -renLibrary :: Int -> [LibraryField] -> String-renLibrary _ [] = ""-renLibrary lvl xs = indent lvl "Library"-  ++ concatMap (renderIndented (lvl + 1)) xs+renLibrary :: [LibraryField] -> Reader Level String+renLibrary [] = return ""+renLibrary xs = (++) <$> indent "Library\n"+  <*> addLevel (fmap concat . mapM renderIndented $ 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+  renderIndented s = case s of+    SecRepo x -> renderIndented x+    SecExe x -> renderIndented x+    SecTest x -> renderIndented x+    SecBench x -> renderIndented 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+  renderIndented (Cabal prop lib secs fls)+    = fmap vsep . sequence+      $ renderIndented prop+      : renLibrary lib+      : map renderIndented secs+      ++ map renderIndented fls 

@@ -11,4 +11,4 @@ import Data.Word  version :: [Word]-version = [0,12,0,2]+version = [0,14,0,0]

@@ -3,12 +3,15 @@  import Cartel import Cartel.Betsy+import Cartel.Ast+import Cartel.Render 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+import Data.List (nub, sort)  type Gen = ReaderT Word (Betsy (State StdGen)) @@ -113,6 +116,8 @@                 [ fmap lt genVersion                 , fmap gt genVersion                 , fmap eq genVersion+                , fmap ltEq genVersion+                , fmap gtEq genVersion                 , return anyVersion                 ]              | otherwise = do@@ -138,7 +143,7 @@   | otherwise = upper   where     lowest [] = nonFlagLevel-    lowest xs = elements (fmap fst xs) >>= withFlagLevel+    lowest xs = elements (fmap (\(Flag nm _) -> nm) xs) >>= withFlagLevel     nonFlagLevel = oneOf [ fmap system genNonEmptyString                          , fmap arch genNonEmptyString                          , liftM2 impl arbitrary arbitrary@@ -202,12 +207,13 @@   -- ^ How many flags?   -> Gen () addFlagsToState nFlags = do-  let mkf = do-        nm <- genNonEmptyString+  allNames <- replicateM (fromIntegral nFlags) genNonEmptyString+  let names = nub . sort $ allNames+      mkf nm = do         opts <- arbitrary         _ <- lift (makeFlag nm opts)         return ()-  _ <- replicateM (fromIntegral nFlags) mkf+  _ <- mapM mkf names   return ()  downsize :: Gen a -> Gen a@@ -319,7 +325,8 @@     sz <- getSize     nFlags <- choose (0, sz)     addFlagsToState nFlags-    liftM3 cabal arbitrary arbitrary arbitrary+    Cabal <$> arbitrary <*> arbitrary <*> arbitrary <*>+      lift currentFlags  -- | Generates Cabal text given a size parameter and int to generate a -- seed.  Read the function from the bottom up:@@ -328,17 +335,19 @@ -- -- * 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 '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+-- * runs the state computation with an initial state initialized by+-- the given seed ----- * gets the Either, discards the resulting state, resulting in an--- @Either Error String@+-- * fetches just the result of the state computation, discarding the+-- ending state ----- * transforms the @Error@ to a string+-- * fetches just the resulting Cabal record, discarding the flags+-- created in the 'Betsy'+--+-- * Renders either the error or the Cabal record genCabalText   :: Word   -- ^ Size@@ -347,13 +356,15 @@   -> Either String String   -- ^ Either an error message, or the Cabal text. genCabalText sz sd-  = either (Left . renderIndented 0) (Right . id)+  = either (Left . renderNoIndent) (Right . renderNoIndent)+  . fmap fst   . fst   . flip runState (mkStdGen sd)-  . renderBetsy+  . runBetsy   . flip runReaderT sz-  $ arbitrary+  $ (arbitrary :: Gen Cabal) + genResult   :: Gen a   -- ^ Generator@@ -365,7 +376,7 @@   -- ^ Random seed   -> Either String a genResult gen nFlags sz sd-  = either (Left . renderIndented 0) (Right . fst)+  = either (Left . renderNoIndent) (Right . fst)   . fst   . flip runState (mkStdGen sd)   . runBetsy

@@ -6,6 +6,7 @@ module Cartel.Properties where  import Cartel+import Cartel.Ast import Control.Monad import Test.QuickCheck import qualified Cartel.Generators as G