diff --git a/cartel.cabal b/cartel.cabal --- a/cartel.cabal +++ b/cartel.cabal @@ -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 diff --git a/lib/Cartel.hs b/lib/Cartel.hs --- a/lib/Cartel.hs +++ b/lib/Cartel.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) diff --git a/lib/Cartel/Ast.hs b/lib/Cartel/Ast.hs --- a/lib/Cartel/Ast.hs +++ b/lib/Cartel/Ast.hs @@ -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 [] [] [] diff --git a/lib/Cartel/Betsy.hs b/lib/Cartel/Betsy.hs --- a/lib/Cartel/Betsy.hs +++ b/lib/Cartel/Betsy.hs @@ -5,6 +5,7 @@ , flagNameHead , flagNameTail , FlagOpts(..) + , Flag(..) , Betsy , Error(..) , runBetsy diff --git a/lib/Cartel/Betsy/Internal.hs b/lib/Cartel/Betsy/Internal.hs --- a/lib/Cartel/Betsy/Internal.hs +++ b/lib/Cartel/Betsy/Internal.hs @@ -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)) diff --git a/lib/Cartel/Render.hs b/lib/Cartel/Render.hs --- a/lib/Cartel/Render.hs +++ b/lib/Cartel/Render.hs @@ -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 diff --git a/lib/Cartel/Version.hs b/lib/Cartel/Version.hs --- a/lib/Cartel/Version.hs +++ b/lib/Cartel/Version.hs @@ -11,4 +11,4 @@ import Data.Word version :: [Word] -version = [0,12,0,2] +version = [0,14,0,0] diff --git a/tests/Cartel/Generators.hs b/tests/Cartel/Generators.hs --- a/tests/Cartel/Generators.hs +++ b/tests/Cartel/Generators.hs @@ -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 diff --git a/tests/Cartel/Properties.hs b/tests/Cartel/Properties.hs --- a/tests/Cartel/Properties.hs +++ b/tests/Cartel/Properties.hs @@ -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