megaparsec/tests/Expr.hs

--
-- QuickCheck tests for Megaparsec's expression parsers.
--
-- Copyright © 2015–2016 Megaparsec contributors
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright notice,
--   this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright
--   notice, this list of conditions and the following disclaimer in the
--   documentation and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.

{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}

module Expr (tests) where

import Control.Applicative (some, (<|>))
import Data.Char (isDigit, digitToInt)

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

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)
#endif

tests :: Test
tests = testGroup "Expression parsers"
  [ testProperty "correctness of expression parser" prop_correctness
  , testProperty "error message on empty input"     prop_empty_error
  , testProperty "error message on missing term"    prop_missing_term
  , testProperty "error message on missing op"      prop_missing_op ]

-- 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 = (if node > parent then showCmp else showNode) node

showGE :: Node -> Node -> String
showGE parent node = (if node >= parent then showCmp else showNode) node

showCmp :: Node -> String
showCmp node = (if fromEnum node == 0 then showNode else inParens) 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 are put here since we don't want to depend on
-- "Text.Megaparsec.Lexer".

lexeme :: MonadParsec s m Char => m a -> m a
lexeme p = p <* hidden space

symbol :: MonadParsec s m Char => String -> m String
symbol = lexeme . string

parens :: MonadParsec s m Char => m a -> m a
parens = between (symbol "(") (symbol ")")

integer :: MonadParsec s m Char => 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 :: MonadParsec s m Char => m Node
expr = makeExprParser term table

term :: MonadParsec s m Char => m Node
term = parens expr <|> (Val <$> integer) <?> "term"

table :: MonadParsec s m Char => [[Operator 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)

prop_empty_error :: Property
prop_empty_error = checkParser expr r s
  where r = posErr 0 s [uneEof, exSpec "term"]
        s = ""

prop_missing_term :: Char -> Property
prop_missing_term c = checkParser expr r s
  where r | c `elem` "-(" = posErr 1 s [uneEof, exSpec "term"]
          | isDigit c     = Right . Val . fromIntegral . digitToInt $ c
          | otherwise     = posErr 0 s [uneCh c, exSpec "term"]
        s = pure c

prop_missing_op :: Node -> Node -> Property
prop_missing_op a b = checkParser expr r s
  where a' = inParens a
        c = s !! n
        n = succ $ length a'
        r | c == '-'  = Right $ Sub a b
          | otherwise = posErr n s [uneCh c, exEof, exSpec "operator"]
        s = a' ++ " " ++ inParens b