diff --git a/FEATURES.md b/FEATURES.md --- a/FEATURES.md +++ b/FEATURES.md @@ -48,5 +48,7 @@ # Miscellaneous -* Some Haddock documentation, probably more to come +* Refactored and conceptually clean code +* Some Haddock documentation. Perhaps more to come * Description in FEATURES.md +* Readme contains examples for print and QuickCheck. Perhaps more to come. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,6 +27,36 @@ ) ``` -Have a look at the [list of features](FEATURES.md). +# QuickCheck + +If you have any intermediate computation within a QuickCheck property, it can +be useful to print a counterexample simply in case of failure + +```haskell +{-# LANGUAGE QuasiQuotes #-} + +import Debug.Dump +import Test.QuickCheck + +($>) = flip ($); infixl 0 $> + +prop :: Float -> Property +prop n = n == 1 / (1 / n) + $> counterexample [d|n, 1/n, 1/(1/n)|] + +main = quickCheck prop +``` + +Which, when executed, will print something like this: + +``` +*** Failed! Falsifiable (after 15 tests and 133 shrinks): +1.7051912e-38 +(n) = 1.7051912e-38 (1/n) = 5.864445e37 (1/(1/n)) = 1.7051913e-38 +``` + +Isn't it nice to see the intermediate computations as well? + +See also: [list of features](FEATURES.md) *Concieved at [this StackOverflow question](http://stackoverflow.com/q/31349556/499478).* diff --git a/dump.cabal b/dump.cabal --- a/dump.cabal +++ b/dump.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: dump -version: 0.2.6 +version: 0.2.7 synopsis: Dumps the names and values of expressions to ease debugging. @@ -15,7 +15,7 @@ license-file: LICENSE author: Milán Nagy maintainer: dumplibhs.psssst@dfgh.net -category: Development +category: Development, QuasiQuotes build-type: Simple extra-source-files: README.md, FEATURES.md, CHANGES.md cabal-version: >=1.10 @@ -27,13 +27,11 @@ library exposed-modules: Debug.Dump - other-modules: Utils, Internal.Parse - -- other-extensions: + other-modules: Internal.Utils, Internal.Parser build-depends: base >=4 && <5 , template-haskell , haskell-src-meta - , interpolatedstring-perl6 - , text + , interpolatedstring-perl6 == 1.0.* ghc-options: --ddump-splices --funbox-strict-fields @@ -43,17 +41,16 @@ test-suite spec type: exitcode-stdio-1.0 - build-depends: base - , hspec - + build-depends: base >=4 && <5 , template-haskell , haskell-src-meta - , interpolatedstring-perl6 - , text + , interpolatedstring-perl6 == 1.0.* + , hspec + , QuickCheck + ghc-options: + --ddump-splices hs-source-dirs: spec, src main-is: Spec.hs default-language: Haskell2010 default-extensions: QuasiQuotes - ghc-options: - -- -ddump-splices diff --git a/spec/Spec.hs b/spec/Spec.hs --- a/spec/Spec.hs +++ b/spec/Spec.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE QuasiQuotes #-} - import Test.Hspec +import Test.QuickCheck -import Debug.Dump -import Internal.Parse import Text.InterpolatedString.Perl6 -import Utils +import Data.List (isPrefixOf) +import Debug.Dump +import Internal.Parser +import Internal.Utils + main = spec spec = hspec $ do @@ -15,61 +16,106 @@ wrapInParens "a" `shouldBe` "(a)" wrapInParens "" `shouldBe` "()" - describe "parseExp" $ do + describe "parseLeaf" $ do + let p = parseLeaf (\xs->("",xs)) '"' + it "knows to stop on regular quote" $ do + p [q|a" |] `shouldBe` ([q|a"|], " ") + + it "knows not to terminate after escaped quote" $ do + p [q|a\"" |] `shouldBe` ([q|a\""|], " ") + + it "does not trip up on escape characters" $ do + p [q|a\\ |] `shouldBe` ([q|a\\ |], "") + + it "does not trip up on escape character at the end" $ do + p [q|a\\|] `shouldBe` ([q|a\\|], "") + + describe "parseExpr" $ do + let p = parseExpr .> fst it "handles flat" $ do - pExp "asd" `shouldBe` "asd" - pExp "asd,asd" `shouldBe` "asd" - pExp "asd,a,sd" `shouldBe` "asd" + p "asd" `shouldBe` "asd" + p "asd,asd" `shouldBe` "asd" + p "asd,a,sd" `shouldBe` "asd" it "handles parens" $ do - pExp "(a,b)" `shouldBe` "(a,b)" - pExp "(a,b) (a,b)" `shouldBe` "(a,b) (a,b)" - pExp "(a,b), c" `shouldBe` "(a,b)" - pExp "((a), b), c" `shouldBe` "((a), b)" - pExp "((a,b),(a,b)), a" `shouldBe` "((a,b),(a,b))" + p "(a,b)" `shouldBe` "(a,b)" + p "(a,b) (a,b)" `shouldBe` "(a,b) (a,b)" + p "(a,b), c" `shouldBe` "(a,b)" + p "((a), b), c" `shouldBe` "((a), b)" + p "((a,b),(a,b)), a" `shouldBe` "((a,b),(a,b))" it "handles char literals" $ do - pExp "','" `shouldBe` "','" - pExp "',', a" `shouldBe` "','" + p "','" `shouldBe` "','" + p "',', a" `shouldBe` "','" it "handles string literals" $ do - pExp [q|","|] `shouldBe` [q|","|] - pExp [q|",", a|] `shouldBe` [q|","|] + p [q|","|] `shouldBe` [q|","|] + p [q|",", a|] `shouldBe` [q|","|] it "handles list literals" $ do - pExp "[a,b]" `shouldBe` "[a,b]" + p "[a,b]" `shouldBe` "[a,b]" it "treats string literals as leaves" $ do - pExp [q|"(", a|] `shouldBe` [q|"("|] + p [q|"(", a|] `shouldBe` [q|"("|] it "support escaping in leaves" $ do - pExp [q|"\"", a|] `shouldBe` [q|"\""|] - pExp [q|"a" ++ "b", a|] `shouldBe` [q|"a" ++ "b"|] + p [q|"\"", a|] `shouldBe` [q|"\""|] + p [q|"a" ++ "b", a|] `shouldBe` [q|"a" ++ "b"|] it "misc" $ do - pExp [q|"((", a|] `shouldBe` [q|"(("|] - pExp [q|"()(", a|] `shouldBe` [q|"()("|] - pExp "(a, )" `shouldBe` "(a, )" - pExp "(, b)" `shouldBe` "(, b)" - -- pExp "([)], a" `shouldBe` "([)]" + p [q|"((", a|] `shouldBe` [q|"(("|] + p [q|"()(", a|] `shouldBe` [q|"()("|] + p "(a, )" `shouldBe` "(a, )" + p "(, b)" `shouldBe` "(, b)" - describe "parseExp" $ do - it "treats string literals as leaves" $ do - pLeaf '"' "a\", b" `shouldBe` "a" - pLeaf '"' "a\\\"\", b" `shouldBe` "a\\\"" - pLeaf '"' "a\\" `shouldBe` "a\\" + it "shouldn't modify the list" $ do + p "[" `shouldBe` "[" + p "([)]" `shouldBe` "([)]" + -- p "([)], a" `shouldBe` "([)]" - describe "separate" $ do + it "shouldn't modify the list (QuickCheck)" $ property $ let + prop :: String -> Property + prop s = (parseExpr s $> fst) `isPrefixOf` s + $> counterexample [d|show s, parseExpr s|] + in prop + + describe "parseExp'" $ do it "should work" $ do - separate "a" `shouldBe` ["a"] - separate "a,b" `shouldBe` ["a", "b"] - separate "a, b" `shouldBe` ["a", " b"] - separate "(a)" `shouldBe` ["(a)"] - separate "(a, b)" `shouldBe` ["(a, b)"] - separate "(a, b), b" `shouldBe` ["(a, b)", " b"] - separate "','" `shouldBe` ["','"] - separate "a ',' b" `shouldBe` ["a ',' b"] - separate "(a, b \")\"), b" `shouldBe` ["(a, b \")\")", " b"] + let p = parseExp' + p [] "asd" `shouldBe` ("asd", "") + p [] "a,b" `shouldBe` ("a", "b") + p ")" "a,b" `shouldBe` ("a,b", "") + p [] "(a,b)" `shouldBe` ("(a,b)", "") + p [] "(a,b),c" `shouldBe` ("(a,b)", "c") + p [] "[a,b],c" `shouldBe` ("[a,b]", "c") + p "]]" "],b],c" `shouldBe` ("],b]", "c") + p [] [q|"a,b",c|] `shouldBe` ([q|"a,b"|], "c") + p [] [q|',',c|] `shouldBe` ([q|','|], "c") + p [] [q|'"',c|] `shouldBe` ([q|'"'|], "c") + -- p [] [q|'\',',|] `shouldBe` ([q|'\','|], "c") + p [] [q|"\",",c|] `shouldBe` ([q|"\","|], "c") + p [] [q|'\'',c|] `shouldBe` ([q|'\''|], "c") + p [] [q|(\),c|] `shouldBe` ([q|(\)|], "c") + + -- TODO decide + -- it "should? handle quotes int its own stack" $ do + -- p ['"'] [q|a,b",c|] `shouldBe` ([q|a,b"|], "c") + -- p ['"'] [q|(a",c|] `shouldBe` ([q|(a"|], "c") + -- p ['\''] [q|,',c|] `shouldBe` ([q|,'|], "c") + + describe "splitOnCommas" $ do + it "should work" $ do + let s = splitOnCommas + s "a" `shouldBe` ["a"] + s "a,b" `shouldBe` ["a", "b"] + s "a, b" `shouldBe` ["a", " b"] + s "(a)" `shouldBe` ["(a)"] + s "(a, b)" `shouldBe` ["(a, b)"] + s "(a, b), b" `shouldBe` ["(a, b)", " b"] + s "','" `shouldBe` ["','"] + s "a ',' b" `shouldBe` ["a ',' b"] + s "(a, b \")\"), b" `shouldBe` ["(a, b \")\")", " b"] + s "(a, b \")\\\",\"), b" `shouldBe` ["(a, b \")\\\",\")", " b"] describe "Debug.Dump" $ do -- TODO decide if this is useful enough to warrant support diff --git a/src/Debug/Dump.hs b/src/Debug/Dump.hs --- a/src/Debug/Dump.hs +++ b/src/Debug/Dump.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# LANGUAGE DeriveFunctor #-} {-| @@ -9,11 +10,45 @@ import Debug.Dump (dd) @ +Example usage: + +@ +{-\# LANGUAGE QuasiQuotes \#-} + +import Debug.Dump + +main = print [d|a, a+1, map (+a) [1..3]|] + where a = 2 +@ + +which prints: + +@ +(a) = 2 (a+1) = 3 (map (+a) [1..3]) = [3,4,5] +@ + +by turnint this String + +@ +"a, a+1, map (+a) [1..3]" +@ + +into this expression + +@ +( "(a) = " ++ show (a) ++ "\t " ++ + "(a+1) = " ++ show (a + 1) ++ "\t " ++ + "(map (+a) [1..3]) = " ++ show (map (+ a) [1 .. 3]) +) +@ + -} module Debug.Dump (d, dd, dump) where -import Utils +import Internal.Utils (($>), (.>)) +import qualified Internal.Utils as Utils +import qualified Internal.Parser as Parser import Data.List import Debug.Trace import Language.Haskell.TH @@ -21,7 +56,6 @@ import Language.Haskell.Meta.Parse import Text.InterpolatedString.Perl6 - -- | This is the main `QuasiQuoter`. dump :: QuasiQuoter dump = QuasiQuoter {quoteExp = process} @@ -32,22 +66,36 @@ -- | Shorthand for `dump`. dd = dump + +newtype HsExp a = HsExp a deriving (Functor) +unHsExp (HsExp s) = s + +instance Applicative HsExp where + pure = HsExp + (HsExp f) <*> (HsExp a) = HsExp $ f a + process :: String -> Q Exp -process str = pairsOf str $> parse $> return - where - pairsOf :: String -> String - pairsOf str = join (map pairOf list) $> wrapInParens - where - join :: [String] -> String - join = intercalate ([q| ++ "\t " ++ |] :: String) - list :: [String] - list = separate str - pairOf :: String -> String - pairOf str = [qq|"($stripped) = " ++ show ($str)|] - where - stripped :: String - stripped = strip str - parse :: String -> Exp - parse = parseExp .> either error id +process = id + .> splitOnCommas + .> map nameAndValue + .> joinAsColumns + .> wrapInParens + .> parseHsStrToQQExp + .> return + +splitOnCommas :: String -> [HsExp String] +splitOnCommas = Parser.splitOnCommas .> map HsExp + +nameAndValue :: HsExp String -> HsExp String +nameAndValue = fmap $ \str-> [qq|"({Utils.strip str}) = " ++ show ($str)|] + +joinAsColumns :: [HsExp String] -> HsExp String +joinAsColumns = sequenceA .> fmap (intercalate [q| ++ "\t " ++ |]) + +wrapInParens :: HsExp String -> HsExp String +wrapInParens = fmap Utils.wrapInParens + +parseHsStrToQQExp :: HsExp String -> Exp +parseHsStrToQQExp = unHsExp .> parseExp .> either error id diff --git a/src/Internal/Parse.hs b/src/Internal/Parse.hs deleted file mode 100644 --- a/src/Internal/Parse.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Internal.Parse where - -import Debug.Trace - -parseSimple :: String -> [String] -parseSimple "" = [] -parseSimple str = match : parseSimple rest - where - match = pExp str - rest = drop (length match + 1) str - -pExp :: String -> String -pExp = pUntil 0 ',' - -pUntil :: Int -> Char -> String -> String -pUntil _ _ "" = "" -pUntil i c (x : xs) - | x == c = "" - | x == '(' = x : matchAndRest ')' - | x == '[' = x : matchAndRest ']' - | x == '\'' = x : leaf '\'' - | x == '"' = x : leaf '"' - | otherwise = x : pUntil i c xs - where - matchAndRest = factory $ pUntil $ i + 1 - leaf = factory pLeaf - factory :: (Char -> String -> String) -> Char -> String - factory f cc = match ++ [cc] ++ pUntil i c rest - where - match = f cc xs - rest = drop (length match + 1) xs - -pLeaf :: Char -> String -> String -pLeaf _ "" = "" -pLeaf cc (x:xs) - | x == cc = "" - | x == '\\' = x : case xs of - "" -> "" - (y:ys) -> y : pLeaf cc ys - | otherwise = x : pLeaf cc xs diff --git a/src/Internal/Parser.hs b/src/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Parser.hs @@ -0,0 +1,36 @@ +module Internal.Parser where + +type Parser = String -> (String, String) + +splitOnCommas :: String -> [String] +splitOnCommas "" = [] +splitOnCommas expr = m : splitOnCommas r + where (m, r) = parseExpr expr + +parseExpr :: Parser +parseExpr = parseExp' [] + +parseExp' :: [Char] -> Parser +parseExp' _ "" = ("", "") +parseExp' [] (',':xs) = ("", xs) +parseExp' (s:tack) (x:xs) | x == s = withMatch x $ parseExp' tack xs +parseExp' stack (x:xs) = withMatch x $ case x of + '(' -> parseExp' (')':stack) xs + '[' -> parseExp' (']':stack) xs + '"' -> parseLeaf (parseExp' stack) '"' xs + '\'' -> parseLeaf (parseExp' stack) '\'' xs + _ -> parseExp' stack xs + +parseLeaf :: Parser -> Char -> Parser +parseLeaf _ _ "\\" = ("\\", "") +parseLeaf _ _ "" = ("", "") +parseLeaf cont cc (x:xs) = withMatch x result + where + result + | x == cc = cont xs + | x == '\\' = withMatch y $ parseLeaf cont cc ys + | otherwise = parseLeaf cont cc xs + (y:ys) = xs + +withMatch :: a -> ([a], [b]) -> ([a], [b]) +withMatch x (m, r) = (x:m, r) diff --git a/src/Internal/Utils.hs b/src/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Utils.hs @@ -0,0 +1,17 @@ +module Internal.Utils where + +import qualified Data.Text as T +import Text.InterpolatedString.Perl6 +import Debug.Trace +import Internal.Parser + +(.>) = flip (.); infixl 9 .> +($>) = flip ($); infixl 0 $> + +strip = T.unpack . T.strip . T.pack + +wrapInParens :: String -> String +wrapInParens = wrapIn "(" ")" + +wrapIn :: String -> String -> String -> String +wrapIn a c b = a ++ b ++ c diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Utils where - -import qualified Data.Text as T -import Text.InterpolatedString.Perl6 -import Debug.Trace -import Internal.Parse - -(.>) = flip (.); infixl 9 .> -($>) = flip ($); infixl 0 $> - -strip = T.unpack . T.strip . T.pack - -wrapInParens :: String -> String -wrapInParens = wrapIn "(" ")" - -wrapIn :: String -> String -> String -> String -wrapIn a c b = a ++ b ++ c - -separate :: String -> [String] -separate = parseSimple --- separate = wordsWhen (== ',') - -wordsWhen :: (Char -> Bool) -> String -> [String] -wordsWhen p s = case dropWhile p s of - "" -> [] - s' -> w : wordsWhen p s'' - where (w, s'') = break p s'