From b35ecbc31f27a32ed546d4bf31195929151cd184 Mon Sep 17 00:00:00 2001
From: mrkkrp <markkarpov@opmbx.org>
Date: Sat, 29 Aug 2015 16:54:45 +0600
Subject: [PATCH] =?UTF-8?q?added=20tests=20for=20=E2=80=98Text.Megaparsec.?=
 =?UTF-8?q?Expr=E2=80=99?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The single test covers 100 % of the module's code. However it doesn't
check quality of error messages, so we still have room for improvement.

Manual tests show that error messages are good.
---
 megaparsec.cabal |   3 +-
 tests/Expr.hs    | 124 ++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 124 insertions(+), 3 deletions(-)

diff --git a/megaparsec.cabal b/megaparsec.cabal
index aabfea3..ae96fdd 100644
--- a/megaparsec.cabal
+++ b/megaparsec.cabal
@@ -140,7 +140,8 @@ test-suite tests
                    , test-framework         >= 0.6 && < 1
                    , test-framework-quickcheck2 >= 0.3 && < 0.4
   default-extensions:
-                     FlexibleInstances
+                     FlexibleContexts
+                   , FlexibleInstances
   default-language:  Haskell2010
 
 benchmark benchmarks
diff --git a/tests/Expr.hs b/tests/Expr.hs
index f18d317..3f14b8c 100644
--- a/tests/Expr.hs
+++ b/tests/Expr.hs
@@ -29,10 +29,130 @@
 
 module Expr (tests) where
 
-import Test.Framework
+import Control.Applicative (some, (<|>))
+import Data.Bool (bool)
 
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck
+
+import Text.Megaparsec.Char
+import Text.Megaparsec.Combinator
 import Text.Megaparsec.Expr
+import Text.Megaparsec.Prim
+
+import Util
 
 tests :: Test
 tests = testGroup "Expression parsers"
-        []
+        [ testProperty "correctness of expression parser" prop_correctness ]
+
+-- Algebraic structures to build abstract syntax tree of our expression.
+
+data Node
+  = Val Integer   -- ^ literal value
+  | Neg Node      -- ^ negation (prefix unary)
+  | Fac Node      -- ^ factorial (postfix unary)
+  | Mod Node Node -- ^ modulo
+  | Sum Node Node -- ^ summation (addition)
+  | Sub Node Node -- ^ subtraction
+  | Pro Node Node -- ^ product
+  | Div Node Node -- ^ division
+  | Exp Node Node -- ^ exponentiation
+    deriving (Eq, Show)
+
+instance Enum Node where
+  fromEnum (Val _)   = 0
+  fromEnum (Neg _)   = 0
+  fromEnum (Fac _)   = 0
+  fromEnum (Mod _ _) = 0
+  fromEnum (Exp _ _) = 1
+  fromEnum (Pro _ _) = 2
+  fromEnum (Div _ _) = 2
+  fromEnum (Sum _ _) = 3
+  fromEnum (Sub _ _) = 3
+  toEnum   _         = error "Oops!"
+
+instance Ord Node where
+  x `compare` y = fromEnum x `compare` fromEnum y
+
+showNode :: Node -> String
+showNode (Val x)     = show x
+showNode n@(Neg x)   = "-" ++ showGT n x
+showNode n@(Fac x)   = showGT n x ++ "!"
+showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y
+showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y
+showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y
+showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y
+showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y
+showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y
+
+showGT :: Node -> Node -> String
+showGT parent node = bool showNode showCmp (node > parent) node
+
+showGE :: Node -> Node -> String
+showGE parent node = bool showNode showCmp (node >= parent) node
+
+showCmp :: Node -> String
+showCmp node = bool inParens showNode (fromEnum node == 0) node
+
+inParens :: Node -> String
+inParens x = "(" ++ showNode x ++ ")"
+
+instance Arbitrary Node where
+  arbitrary = sized arbitraryN0
+
+arbitraryN0 :: Int -> Gen Node
+arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)
+                          , (9, arbitraryN1 n) ]
+  where leaf = arbitraryN1 (n `div` 2)
+
+arbitraryN1 :: Int -> Gen Node
+arbitraryN1 n =
+  frequency [ (1, Neg <$> arbitraryN2 n)
+            , (1, Fac <$> arbitraryN2 n)
+            , (7, arbitraryN2 n)]
+
+arbitraryN2 :: Int -> Gen Node
+arbitraryN2 0 = Val . getNonNegative <$> arbitrary
+arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf
+  where leaf = arbitraryN0 (n `div` 2)
+
+-- Some helpers put here since we don't want to depend on
+-- "Text.Megaparsec.Token".
+
+lexeme :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
+lexeme p = p <* hidden space
+
+symbol :: Stream s m Char => String -> ParsecT s u m String
+symbol = lexeme . string
+
+parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
+parens = between (symbol "(") (symbol ")")
+
+integer :: Stream s m Char => ParsecT s u m Integer
+integer = lexeme (read <$> some digitChar <?> "integer")
+
+-- Here we use table of operators that makes use of all features of
+-- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex
+-- but valid expressions and render them to get their textual
+-- representation.
+
+expr :: Stream s m Char => ParsecT s u m Node
+expr = makeExprParser term table <?> "expression"
+
+term :: Stream s m Char => ParsecT s u m Node
+term = parens expr <|> (Val <$> integer) <?> "term"
+
+table :: Stream s m Char => [[Operator s u m Node]]
+table = [ [ Prefix  (symbol "-" *> pure Neg)
+          , Postfix (symbol "!" *> pure Fac)
+          , InfixN  (symbol "%" *> pure Mod) ]
+        , [ InfixR  (symbol "^" *> pure Exp) ]
+        , [ InfixL  (symbol "*" *> pure Pro)
+          , InfixL  (symbol "/" *> pure Div) ]
+        , [ InfixL  (symbol "+" *> pure Sum)
+          , InfixL  (symbol "-" *> pure Sub)] ]
+
+prop_correctness :: Node -> Property
+prop_correctness node = checkParser expr (Right node) (showNode node)