prednote 0.32.0.6 → 0.34.0.0
raw patch · 5 files changed
+142/−195 lines, 5 filesdep ~rainbow
Dependency ranges changed: rainbow
Files
- genCabal.hs +5/−8
- lib/Prednote/Comparisons.hs +7/−7
- lib/Prednote/Core.hs +53/−55
- prednote.cabal +39/−42
- tests/Rainbow/Instances.hs +38/−83
genCabal.hs view
@@ -8,13 +8,13 @@ import Control.Applicative versionInts :: [Word]-versionInts = [0,32,0,6]+versionInts = [0,34,0,0] base :: Package base = closedOpen "base" [4,7] [4,9] rainbow :: Package-rainbow = nextBreaking "rainbow" [0,22]+rainbow = nextBreaking "rainbow" [0,24] text :: Package text = closedOpen "text" [0,11,2,0] [1,3]@@ -127,13 +127,10 @@ [ mainIs "prednote-tests.hs" , exitcodeStdio ]- , executable "prednote-visual-tests" $+ , testSuite "prednote-visual-tests" $ [ mainIs "prednote-visual-tests.hs"- , condBlock (flag fl)- ( buildable True, commonTestOpts ls ts)- [ buildable False- ]- ]+ , exitcodeStdio+ ] ++ commonTestOpts ls ts ) commonTestOpts
lib/Prednote/Comparisons.hs view
@@ -35,8 +35,8 @@ import Prelude hiding (compare, not) import qualified Prelude import Data.Monoid+import Data.Text (Text) import qualified Data.Text as X-import Data.String import Rainbow -- | Build a Pred that compares items. The idea is that the item on@@ -65,8 +65,8 @@ where mkTup ord = (bl, val, cond) where- val = Value [fromString . show $ a]- cond = Condition [chunkFromText condTxt]+ val = Value [chunk . X.pack . show $ a]+ cond = Condition [chunk condTxt] condTxt = "is" <+> ordDesc <+> rhsDesc ordDesc = case ord of EQ -> "equal to"@@ -129,8 +129,8 @@ where f a = fmap mkTup (get a) where- mkTup bl = (bl, Value [fromString . show $ a],- Condition [chunkFromText $ "is equal to" <+> rhsDesc])+ mkTup bl = (bl, Value [chunk . X.pack . show $ a],+ Condition [chunk $ "is equal to" <+> rhsDesc]) -- | Builds a 'Pred' that tests items for equality. @@ -182,8 +182,8 @@ where mkTup mayOrd = (bl, val, cond) where- val = Value [fromString . show $ a]- cond = Condition [chunkFromText $ "is" <+> ordDesc <+> rhsDesc]+ val = Value [chunk . X.pack . show $ a]+ cond = Condition [chunk $ "is" <+> ordDesc <+> rhsDesc] ordDesc = case ord of EQ -> "equal to" LT -> "less than"
lib/Prednote/Core.hs view
@@ -67,11 +67,12 @@ ) where import Rainbow-import Rainbow.Types+import Rainbow.Types (_yarn) import Data.Monoid import Data.Functor.Contravariant import Prelude hiding (all, any, maybe, and, or, not) import qualified Prelude+import Data.Text (Text) import qualified Data.Text as X import Data.List (intersperse) import Data.Functor.Identity@@ -90,7 +91,7 @@ -- | Describes the condition; for example, for a @'Pred' 'Int'@, -- this might be @is greater than 5@; for a @'Pred' 'String'@, this -- might be @begins with \"Hello\"@.-newtype Condition = Condition [Chunk]+newtype Condition = Condition [Chunk Text] deriving (Eq, Ord, Show) instance Monoid Condition where@@ -98,7 +99,7 @@ mappend (Condition x) (Condition y) = Condition (x ++ y) -- | Stores the representation of a value.-newtype Value = Value [Chunk]+newtype Value = Value [Chunk Text] deriving (Eq, Ord, Show) instance Monoid Value where@@ -107,7 +108,7 @@ -- | Gives additional information about a particular 'Pred' to aid the -- user when viewing the output.-newtype Label = Label [Chunk]+newtype Label = Label [Chunk Text] deriving (Eq, Ord, Show) instance Monoid Label where@@ -280,26 +281,26 @@ true :: Applicative f => PredM f a true = predicateM (const (pure trip)) where- trip = (True, mempty, Condition ["always returns True"])+ trip = (True, mempty, Condition [chunk "always returns True"]) -- | Always returns 'False' false :: Applicative f => PredM f a false = predicateM (const (pure trip)) where- trip = (False, mempty, Condition ["always returns False"])+ trip = (False, mempty, Condition [chunk "always returns False"]) -- | Always returns its argument same :: Applicative f => PredM f Bool same = predicateM- (\b -> pure (b, (Value [(chunkFromText . X.pack . show $ b)]),- Condition ["is returned"]))+ (\b -> pure (b, (Value [(chunk . X.pack . show $ b)]),+ Condition [chunk "is returned"])) -- | Adds descriptive text to a 'Pred'. Gives useful information for -- the user. The label is added to the top 'Pred' in the tree; any -- existing labels are also retained. Labels that were added last -- will be printed first. For an example of this, see the source code -- for 'any' and 'all'.-addLabel :: Functor f => [Chunk] -> PredM f a -> PredM f a+addLabel :: Functor f => [Chunk Text] -> PredM f a -> PredM f a addLabel s (PredM f) = PredM f' where f' a = fmap g (f a)@@ -311,31 +312,31 @@ -- 'True'. An empty list returns 'False'. Is lazy; will stop -- processing if it encounters a 'True' item. any :: (Monad m, Applicative m) => PredM m a -> PredM m [a]-any pa = contramap f (switch (addLabel ["cons cell"] pConsCell) pEnd)+any pa = contramap f (switch (addLabel [chunk "cons cell"] pConsCell) pEnd) where pConsCell =- contramap fst (addLabel ["head"] pa)- ||| contramap snd (addLabel ["tail"] (any pa))+ contramap fst (addLabel [chunk "head"] pa)+ ||| contramap snd (addLabel [chunk "tail"] (any pa)) f ls = case ls of [] -> Right () x:xs -> Left (x, xs)- pEnd = predicateM (const (pure (False, Value ["end of list"],- Condition ["always returns False"])))+ pEnd = predicateM (const (pure (False, Value [chunk "end of list"],+ Condition [chunk "always returns False"]))) -- | Like 'Prelude.all'; is 'True' if none of the list items is -- 'False'. An empty list returns 'True'. Is lazy; will stop -- processing if it encouters a 'False' item. all :: (Monad m, Applicative m) => PredM m a -> PredM m [a]-all pa = contramap f (switch (addLabel ["cons cell"] pConsCell) pEnd)+all pa = contramap f (switch (addLabel [chunk "cons cell"] pConsCell) pEnd) where pConsCell =- contramap fst (addLabel ["head"] pa)- &&& contramap snd (addLabel ["tail"] (all pa))+ contramap fst (addLabel [chunk "head"] pa)+ &&& contramap snd (addLabel [chunk "tail"] (all pa)) f ls = case ls of x:xs -> Left (x, xs) [] -> Right ()- pEnd = predicateM (const (pure (True, Value ["end of list"],- Condition ["always returns True"])))+ pEnd = predicateM (const (pure (True, Value [chunk "end of list"],+ Condition [chunk "always returns True"]))) -- | Create a 'Pred' for 'Maybe'.@@ -347,26 +348,26 @@ -- ^ Analyzes 'Just' values -> PredM m (Maybe a) maybe onEmp pa = contramap f- (switch emp (addLabel ["Just value"] pa))+ (switch emp (addLabel [chunk "Just value"] pa)) where emp | onEmp = predicateM (const- (pure (True, noth, Condition ["always returns True"])))+ (pure (True, noth, Condition [chunk "always returns True"]))) | otherwise = predicateM (const- (pure (False, noth, Condition ["always returns False"])))- noth = Value ["Nothing"]+ (pure (False, noth, Condition [chunk "always returns False"])))+ noth = Value [chunk "Nothing"] f may = case may of Nothing -> Left () Just a -> Right a -explainAnd :: [Chunk]-explainAnd = ["(and)"]+explainAnd :: [Chunk Text]+explainAnd = [chunk "(and)"] -explainOr :: [Chunk]-explainOr = ["(or)"]+explainOr :: [Chunk Text]+explainOr = [chunk "(or)"] -explainNot :: [Chunk]-explainNot = ["(not)"]+explainNot :: [Chunk Text]+explainNot = [chunk "(not)"] -- | Runs a 'Pred' against a value. testM :: Functor f => PredM f a -> a -> f Bool@@ -380,75 +381,72 @@ -- | Runs a 'Pred' against a particular value; also returns a list of -- 'Chunk' describing the steps of evaulation.-verboseTestM :: Functor f => PredM f a -> a -> f ([Chunk], Bool)+verboseTestM :: Functor f => PredM f a -> a -> f ([Chunk Text], Bool) verboseTestM (PredM f) a = fmap g (f a) where g rslt = (resultToChunks rslt, resultToBool rslt) -verboseTest :: Pred a -> a -> ([Chunk], Bool)+verboseTest :: Pred a -> a -> ([Chunk Text], Bool) verboseTest p a = runIdentity $ verboseTestM p a -- | Obtain a list of 'Chunk' describing the evaluation process.-resultToChunks :: Result -> [Chunk]+resultToChunks :: Result -> [Chunk Text] resultToChunks = either (failedToChunks 0) (passedToChunks 0) . splitResult -- | A colorful label for 'True' values.-lblTrue :: [Chunk]-lblTrue = ["[", fore green <> "TRUE", "]"]+lblTrue :: [Chunk Text]+lblTrue = [chunk "[", chunk "TRUE" & fore green, chunk "]"] -- | A colorful label for 'False' values.-lblFalse :: [Chunk]-lblFalse = ["[", fore red <> "FALSE", "]"]+lblFalse :: [Chunk Text]+lblFalse = [chunk "[", chunk "FALSE" & fore red, chunk "]"] -- | Append two lists of 'Chunk', with an intervening space if both -- lists are not empty.-(<+>) :: [Chunk] -> [Chunk] -> [Chunk]+(<+>) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text] l <+> r- | full l && full r = l <> [" "] <> r+ | full l && full r = l <> [chunk " "] <> r | otherwise = l <> r where- full = Prelude.not . chunksNull+ full = Prelude.any (Prelude.not . X.null) . map _yarn -- | Append two lists of 'Chunk', with an intervening hyphen if both -- lists have text.-(<->) :: [Chunk] -> [Chunk] -> [Chunk]+(<->) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text] l <-> r | full l && full r = l <> hyphen <> r | otherwise = l <> r where- full = Prelude.not . chunksNull--hyphen :: [Chunk]-hyphen = [" - "]+ full = Prelude.any (Prelude.not . X.null) . map _yarn -chunksNull :: [Chunk] -> Bool-chunksNull = Prelude.all $ Prelude.all X.null . chunkTexts+hyphen :: [Chunk Text]+hyphen = [chunk " - "] indentAmt :: Int indentAmt = 2 -spaces :: Int -> [Chunk]-spaces i = (:[]) . chunkFromText . X.replicate (i * indentAmt)+spaces :: Int -> [Chunk Text]+spaces i = (:[]) . chunk . X.replicate (i * indentAmt) . X.singleton $ ' ' -newline :: [Chunk]-newline = ["\n"]+newline :: [Chunk Text]+newline = [chunk "\n"] -labelToChunks :: Label -> [Chunk]+labelToChunks :: Label -> [Chunk Text] labelToChunks (Label cks) = cks -explainTerminal :: Value -> Condition -> [Chunk]+explainTerminal :: Value -> Condition -> [Chunk Text] explainTerminal (Value v) (Condition c)- = v ++ (" " : c)+ = v ++ (chunk " " : c) -- | Obtain a list of 'Chunk' describing the evaluation process. passedToChunks :: Int -- ^ Number of levels of indentation -> Labeled Passed- -> [Chunk]+ -> [Chunk Text] passedToChunks i (Labeled l p) = this <> rest where this = spaces i <> (lblTrue <+> (labels `sep` explain)) <> newline@@ -470,7 +468,7 @@ :: Int -- ^ Number of levels of indentation -> Labeled Failed- -> [Chunk]+ -> [Chunk Text] failedToChunks i (Labeled l p) = this <> rest where this = spaces i <> (lblFalse <+> (labels `sep` explain)) <> newline
prednote.cabal view
@@ -3,11 +3,11 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2015-03-27 15:03:18.090444 EDT--- Cartel library version: 0.14.2.0+-- Generated on: 2015-04-25 17:06:29.193914 EDT+-- Cartel library version: 0.14.2.6 name: prednote-version: 0.32.0.6+version: 0.34.0.0 cabal-version: >= 1.18 license: BSD3 license-file: LICENSE@@ -47,7 +47,7 @@ Prednote.Expressions.RPN build-depends: base >= 4.7 && < 4.9- , rainbow >= 0.22 && < 0.23+ , rainbow >= 0.24 && < 0.25 , split >= 0.2.2 && < 0.3 , text >= 0.11.2.0 && < 1.3 , containers >= 0.4.2.1 && < 0.6@@ -86,7 +86,7 @@ , tasty-th >= 0.1 && < 0.2 , QuickCheck >= 2.7 && < 2.9 , base >= 4.7 && < 4.9- , rainbow >= 0.22 && < 0.23+ , rainbow >= 0.24 && < 0.25 , split >= 0.2.2 && < 0.3 , text >= 0.11.2.0 && < 1.3 , containers >= 0.4.2.1 && < 0.6@@ -96,44 +96,41 @@ main-is: prednote-tests.hs type: exitcode-stdio-1.0 -Executable prednote-visual-tests+Test-Suite prednote-visual-tests main-is: prednote-visual-tests.hs- if flag(visual-tests)- buildable: True- hs-source-dirs:- lib- tests- other-modules:- Prednote- Prednote.Comparisons- Prednote.Core- Prednote.Expressions- Prednote.Expressions.Infix- Prednote.Expressions.RPN- Instances- Prednote.Core.Instances- Prednote.Core.Properties- Rainbow.Instances- ghc-options:- -Wall- default-language: Haskell2010- other-extensions:- TemplateHaskell- build-depends:- tasty >= 0.10 && < 0.11- , tasty-quickcheck >= 0.8 && < 0.9- , tasty-th >= 0.1 && < 0.2- , QuickCheck >= 2.7 && < 2.9- , base >= 4.7 && < 4.9- , rainbow >= 0.22 && < 0.23- , split >= 0.2.2 && < 0.3- , text >= 0.11.2.0 && < 1.3- , containers >= 0.4.2.1 && < 0.6- , contravariant >= 1.2 && < 1.4- , transformers >= 0.3.0.0 && < 0.5- , bytestring >= 0.10 && < 0.11- else- buildable: False+ type: exitcode-stdio-1.0+ hs-source-dirs:+ lib+ tests+ other-modules:+ Prednote+ Prednote.Comparisons+ Prednote.Core+ Prednote.Expressions+ Prednote.Expressions.Infix+ Prednote.Expressions.RPN+ Instances+ Prednote.Core.Instances+ Prednote.Core.Properties+ Rainbow.Instances+ ghc-options:+ -Wall+ default-language: Haskell2010+ other-extensions:+ TemplateHaskell+ build-depends:+ tasty >= 0.10 && < 0.11+ , tasty-quickcheck >= 0.8 && < 0.9+ , tasty-th >= 0.1 && < 0.2+ , QuickCheck >= 2.7 && < 2.9+ , base >= 4.7 && < 4.9+ , rainbow >= 0.24 && < 0.25+ , split >= 0.2.2 && < 0.3+ , text >= 0.11.2.0 && < 1.3+ , containers >= 0.4.2.1 && < 0.6+ , contravariant >= 1.2 && < 1.4+ , transformers >= 0.3.0.0 && < 0.5+ , bytestring >= 0.10 && < 0.11 source-repository head type: git
tests/Rainbow/Instances.hs view
@@ -15,12 +15,16 @@ import Control.Applicative import Test.QuickCheck-import Rainbow.Colors import Rainbow.Types-import Data.Monoid-import Control.Monad import qualified Data.Text as X +instance Arbitrary a => Arbitrary (Color a) where+ arbitrary = Color <$> arbitrary+ shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Color a) where+ coarbitrary (Color a) = coarbitrary a+ varInt :: Int -> Gen b -> Gen b varInt = variant @@ -39,51 +43,15 @@ E6 -> varInt 6 E7 -> varInt 7 -instance Arbitrary Color8 where- arbitrary = fmap Color8 arbitrary- shrink = genericShrink--instance CoArbitrary Color8 where- coarbitrary (Color8 Nothing) = varInt 0- coarbitrary (Color8 (Just e)) = varInt 1 . coarbitrary e--instance Arbitrary Color256 where- arbitrary = fmap Color256 arbitrary- shrink = genericShrink--instance CoArbitrary Color256 where- coarbitrary (Color256 Nothing) = varInt 0- coarbitrary (Color256 (Just w)) = varInt 1 . coarbitrary w--instance Arbitrary (Last Color8) where- arbitrary = fmap Last arbitrary--instance CoArbitrary (Last Color8) where- coarbitrary (Last Nothing) = varInt 0- coarbitrary (Last (Just c)) = varInt 1 . coarbitrary c--instance Arbitrary (Last Color256) where- arbitrary = fmap Last arbitrary--instance CoArbitrary (Last Color256) where- coarbitrary (Last Nothing) = varInt 0- coarbitrary (Last (Just c)) = varInt 1 . coarbitrary c--instance Arbitrary (Last Bool) where- arbitrary = fmap Last arbitrary--instance CoArbitrary (Last Bool) where- coarbitrary (Last Nothing) = varInt 0- coarbitrary (Last (Just b)) = varInt 1 . coarbitrary b--instance Arbitrary StyleCommon where+instance Arbitrary Format where arbitrary- = StyleCommon <$> g <*> g <*> g <*> g <*> g <*> g <*> g <*> g+ = Format <$> g <*> g <*> g <*> g <*> g <*> g <*> g <*> g where- g = fmap Last arbitrary+ g = arbitrary+ shrink = genericShrink -instance CoArbitrary StyleCommon where- coarbitrary (StyleCommon x0 x1 x2 x3 x4 x5 x6 x7)+instance CoArbitrary Format where+ coarbitrary (Format x0 x1 x2 x3 x4 x5 x6 x7) = coarbitrary x0 . coarbitrary x1 . coarbitrary x2@@ -92,53 +60,40 @@ . coarbitrary x5 . coarbitrary x6 . coarbitrary x7- -instance Arbitrary Style256 where- arbitrary = liftM3 Style256 arbitrary arbitrary arbitrary--instance CoArbitrary Style256 where- coarbitrary (Style256 x0 x1 x2)- = coarbitrary x0- . coarbitrary x1- . coarbitrary x2--instance Arbitrary Style8 where- arbitrary = liftM3 Style8 arbitrary arbitrary arbitrary--instance CoArbitrary Style8 where- coarbitrary (Style8 x0 x1 x2)- = coarbitrary x0- . coarbitrary x1- . coarbitrary x2--instance Arbitrary TextSpec where- arbitrary = liftM2 TextSpec arbitrary arbitrary+instance Arbitrary a => Arbitrary (Style a) where+ arbitrary = Style <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -instance CoArbitrary TextSpec where- coarbitrary (TextSpec x0 x1)- = coarbitrary x0- . coarbitrary x1+instance CoArbitrary a => CoArbitrary (Style a) where+ coarbitrary (Style a b c)+ = coarbitrary a+ . coarbitrary b+ . coarbitrary c -instance Arbitrary X.Text where- arbitrary = fmap X.pack arbitrary- shrink = map X.pack . shrink . X.unpack -instance Arbitrary Chunk where- arbitrary = liftM2 Chunk arbitrary- (listOf (fmap X.pack (listOf (elements ['a'..'z']))))+instance Arbitrary a => Arbitrary (Chunk a) where+ arbitrary = Chunk <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -instance CoArbitrary Chunk where- coarbitrary (Chunk ts txts) = coarbitrary ts- . coarbitrary (map X.unpack txts)+instance CoArbitrary a => CoArbitrary (Chunk a) where+ coarbitrary (Chunk a b c)+ = coarbitrary a+ . coarbitrary b+ . coarbitrary c instance Arbitrary Radiant where- arbitrary = liftM2 Radiant arbitrary arbitrary+ arbitrary = Radiant <$> arbitrary <*> arbitrary shrink = genericShrink instance CoArbitrary Radiant where- coarbitrary (Radiant x0 x1)- = coarbitrary x0- . coarbitrary x1+ coarbitrary (Radiant a b) = coarbitrary a . coarbitrary b++instance Arbitrary X.Text where+ arbitrary = fmap X.pack $ listOf genChar+ where+ genChar = elements ['a'..'z']+ shrink = fmap X.pack . shrink . X.unpack++instance CoArbitrary X.Text where+ coarbitrary = coarbitrary . X.unpack