-- | Testing the parser library from lecture 4.
module Main where

import Control.Applicative((<$>), (<*>))
import Control.Arrow(second)
import Data.List(sort)
import Test.QuickCheck
-- import Parsers                   (P, symbol, (+++), pfail, parse)
import PolyParser                   (P, symbol, (+++), pfail, parse)

-- We import the first naive implementation as the specification.
import qualified Parser1 as Spec (P, symbol, (+++), pfail, parse)

-- | We want to generate and show arbitrary parsers. To do this
--   we restrict ourselves to parsers of type P Bool Bool and build
--   a datatype to model these.
data ParsBB
  = Plus ParsBB ParsBB
  | Fail
  | Return Bool
  | Symbol
  | Bind ParsBB B2ParsBB

-- | Instead of arbitrary functions (which quickCheck can handle) we
--   build a datatype modelling a few interesting functions.
data B2ParsBB
  = K ParsBB          -- \_ -> p
  | If ParsBB ParsBB  -- \x -> if x then p1 else p2

-- Applying a function to an argument.
apply :: B2ParsBB -> Bool -> ParsBB
apply (K p)      _ = p
apply (If p1 p2) x = if x then p1 else p2

-- | We can show elements in our model, but not the parsers from the
--   implementation.
instance Show ParsBB where
  showsPrec n p = case p of
    Fail   -> showString "pfail"
    Symbol -> showString "symbol"
    Return x -> showParen (n > 2) $ showString "return " . shows x
    Plus p q -> showParen (n > 0) $ showsPrec 1 p
                                  . showString " +++ "
                                  . showsPrec 1 q
    Bind p f -> showParen (n > 1) $ showsPrec 2 p
                                  . showString " >>= "
                                  . shows f

-- and we can show our functions. That would have been harder if
-- we had used real functions.
instance Show B2ParsBB where
  show (K p)      = "\\_ -> " ++ show p
  show (If p1 p2) = "\\x -> if x then " ++ show p1 ++
                               " else " ++ show p2

-- | Generating an arbitrary parser. Parameterised by a size argument
--   to ensure that we don't generate infinite parsers.
genParsBB :: Int -> Gen ParsBB
genParsBB 0 = oneof [ return Fail
                    , Return <$> arbitrary
                    , return Symbol ]
genParsBB n =
  frequency $
    [ (1, genParsBB 0)
    , (3, Plus <$> gen2 <*> gen2)
    , (5, Bind <$> gen2 <*> genFun2)
    ]
  where
    gen2    = genParsBB (n `div` 2)
    genFun2 = genFun (n `div` 2)

-- | Generating arbitrary functions.
genFun :: Int -> Gen B2ParsBB
genFun n = oneof $
  [ K  <$> genParsBB n
  , If <$> gen2 <*> gen2
  ]
  where
    gen2 = genParsBB (n `div` 2)

instance Arbitrary ParsBB where
  arbitrary = sized genParsBB

  -- Shrinking is used to get minimal counter examples and is very
  -- handy.  The shrink function returns a list of things that are
  -- smaller (in some way) than the argument.
  shrink (Plus p1 p2) = p1 : p2 :
    [ Plus p1' p2 | p1' <- shrink p1 ] ++
    [ Plus p1 p2' | p2' <- shrink p2 ]
  shrink Fail         = [ Return False ]
  shrink (Return x)   = []
  shrink Symbol       = [ Return False ]
  shrink (Bind p k)   = p : apply k False : apply k True :
    [ Bind p' k | p' <- shrink p ] ++
    [ Bind p k' | k' <- shrink k ]

instance Arbitrary B2ParsBB where
  arbitrary = sized genFun

  shrink (K p)      = [ K p | p <- shrink p ]
  shrink (If p1 p2) = K p1 : K p2 :
    [ If p1 p2 | p1 <- shrink p1 ] ++
    [ If p1 p2 | p2 <- shrink p2 ]

-- | We can turn a parser in our model into its specification...
spec :: ParsBB -> Spec.P Bool Bool
spec Symbol       = Spec.symbol
spec (Return x)   = return x
spec (Plus p1 p2) = spec p1   Spec.+++   spec p2
spec Fail         = Spec.pfail
spec (Bind p k)   = spec p >>= \x -> spec (apply k x)

-- | ... or we can compile to a parser from the implementation we're
--   testing.
compile :: ParsBB -> P Bool Bool
compile Symbol       = symbol
compile (Return x)   = return x
compile (Plus p1 p2) = compile p1 +++ compile p2
compile Fail         = pfail
compile (Bind p k)   = compile p >>= compileFun k

compileFun :: B2ParsBB -> (Bool -> P Bool Bool)
compileFun k = \x -> compile (apply k x)

-- Tests

infix 0 =~=

-- | When are two parsers equal? Remember that we don't care
--   about the order of results so we sort the result lists
--   before comparing.
-- (=~=) :: P Bool Bool -> P Bool Bool -> Property
p =~= q = -- forAllShrink arbitrary shrinkNothing $ 
          \s ->
          parse p s  `bagEq`  parse q s

bagEq :: Ord a => [a] -> [a] -> Bool
bagEq xs ys = sort xs == sort ys

-- We can turn all the laws we had into properties.
-- Exercise: check all the laws L1 .. L10.

law1' x f =   return x >>= f   =~=   f x

law1 x f0 =   return x >>= f   =~=   f x
  where f = compileFun f0

law2 p0 =     p >>= return   =~=   p
  where p = compile p0

law3 p0 f0 g0 =  (p >>= f) >>= g  =~=  p >>= (\x -> f x >>= g)
  where p = compile p0
        f = compileFun f0
        g = compileFun g0

law5 p0 q0 f0 =   (p +++ q) >>= f  =~=  (p >>= f) +++ (q >>= f)
  where p = compile p0
        q = compile q0
        f = compileFun f0

law9 p0 q0 =      p +++ q  =~=  q +++ p
  where p = compile p0
        q = compile q0

-- | We can also check that the implementation behaves as the
--   specification.
prop_spec p s  = whenFail debug $ lhs  `bagEq`  rhs
  where
    lhs = parse    (compile p) s
    rhs = Spec.parse (spec p)  s
    debug = do putStrLn ("parse    (compile p) s = " ++ show lhs)
               putStrLn ("Spec.parse (spec p)  s = " ++ show rhs)

----------------
main = do quickCheck law3
          quickCheck prop_spec
          quickCheck law1
          quickCheck law2
          quickCheck law5
          quickCheck law9



















----------------
-- Some unfinished experiments below          

language' :: (Bounded s, Enum s) => P s a -> [[s]]
language' p = filter (parseOK p) allLists

language :: ParsBB -> [[Bool]]
language = language' . compile

parseOK :: P s a -> [s] -> Bool
parseOK p = not . null . parse p

allLists :: (Bounded a, Enum a) => [[a]]
allLists = [] : [ x : xs | xs <- allLists, x <- allA ]
  where allA = [minBound .. maxBound]

test = do ps <- sample' (arbitrary :: Gen ParsBB)
          return $ zip ps (map language ps)