fused-effects-1.1.1.1: examples/Parser.hs

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Parser
( example
) where

import           Control.Algebra
import           Control.Carrier.Cut.Church
import           Control.Carrier.NonDet.Church
import           Control.Carrier.State.Strict
import           Control.Monad (replicateM)
import           Data.Char
import           Data.Kind (Type)
import           Data.List (intercalate)
import           Hedgehog
import qualified Hedgehog.Function as Fn
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import           Utils

example :: TestTree
example = testGroup "parser"
  [ testGroup "parse"
    [ testProperty "returns pure values at the end of input" . property $ do
      a <- forAll genFactor
      run (runNonDetA (parse "" (pure a))) === [a]

    , testProperty "fails if input remains" . property $ do
      c  <- forAll Gen.alphaNum
      cs <- forAll (Gen.string (Range.linear 0 10) Gen.alphaNum)
      a  <- forAll genFactor
      run (runNonDetA (parse (c:cs) (pure a))) === []
    ]

  , testGroup "satisfy"
    [ testProperty "matches with a predicate" . property $ do
      c <- forAll Gen.alphaNum
      f <- (. ord) <$> Fn.forAllFn predicate
      run (runNonDetA (parse [c] (satisfy f))) === [c | f c]

    , testProperty "fails at end of input" . property $ do
      f <- (. ord) <$> Fn.forAllFn predicate
      run (runNonDetA (parse "" (satisfy f))) === []

    , testProperty "fails if input remains" . property $ do
      (c1, c2) <- forAll ((,) <$> Gen.alphaNum <*> Gen.alphaNum)
      f <- (. ord) <$> Fn.forAllFn predicate
      run (runNonDetA (parse [c1, c2] (satisfy f))) === []

    , testProperty "consumes input" . property $ do
      c1 <- forAll Gen.alphaNum
      c2 <- forAll Gen.alphaNum
      f <- (. ord) <$> Fn.forAllFn predicate
      run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === [(c1, c2) | f c1, f c2]
    ]

  , testGroup "factor"
    [ testProperty "matches positive integers" . property $ do
      a <- forAll genFactor
      run (runCutA (parse (show (abs a)) factor)) === [abs a]

    , testProperty "matches parenthesized expressions" . property $ do
      as <- forAll (Gen.sized (arbNested genFactor))
      run (runCutA (parse ('(' : intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as) ++ ")") factor)) === [sum (map (product . map abs) as)]
    ]

  , testGroup "term"
    [ testProperty "matches factors" . property $ do
      a <- forAll genFactor
      run (runCutA (parse (show (abs a)) term)) === [abs a]

    , testProperty "matches multiplication" . property $ do
      as <- forAll genFactors
      run (runCutA (parse (intercalate "*" (show . abs <$> 1:as)) term)) === [product (map abs as)]
    ]

  , testGroup "expr"
    [ testProperty "matches factors" . property $ do
      a <- forAll genFactor
      run (runCutA (parse (show (abs a)) expr)) === [abs a]

    , testProperty "matches multiplication" . property $ do
      as <- forAll genFactors
      run (runCutA (parse (intercalate "*" (show . abs <$> 1:as)) expr)) === [product (map abs as)]

    , testProperty "matches addition" . property $ do
      as <- forAll genFactors
      run (runCutA (parse (intercalate "+" (show . abs <$> 0:as)) expr)) === [sum (map abs as)]

    , testProperty "respects order of operations" . property $ do
      as <- forAll (Gen.sized (arbNested (Gen.integral (Range.linear 0 100))))
      run (runCutA (parse (intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as)) expr)) === [sum (map (product . map abs) as)]
    ]
  ]
  where
  arbNested :: Gen a -> Range.Size -> Gen [[a]]
  arbNested _ 0 = pure []
  arbNested g n = do
    m <- Gen.integral (Range.linear 0 10)
    let n' = n `div` (m + 1)
    replicateM (Range.unSize m) (Gen.list (Range.singleton (Range.unSize n')) g)

  predicate = Fn.fn Gen.bool
  genFactor = Gen.integral (Range.linear 0 100)
  genFactors = Gen.list (Range.linear 0 10) genFactor


data Symbol (m :: Type -> Type) k where
  Satisfy :: (Char -> Bool) -> Symbol m Char


satisfy :: Has Symbol sig m => (Char -> Bool) -> m Char
satisfy p = send (Satisfy p)

char :: Has Symbol sig m => Char -> m Char
char = satisfy . (==)

digit :: Has Symbol sig m => m Char
digit = satisfy isDigit

parens :: Has Symbol sig m => m a -> m a
parens m = char '(' *> m <* char ')'


parse :: (Alternative m, Monad m) => String -> ParseC m a -> m a
parse input = (>>= exhaustive) . runState input . runParseC
  where exhaustive ("", a) = pure a
        exhaustive _       = empty

newtype ParseC m a = ParseC { runParseC :: StateC String m a }
  deriving (Alternative, Applicative, Functor, Monad)

instance (Alternative m, Algebra sig m) => Algebra (Symbol :+: sig) (ParseC m) where
  alg hdl sig ctx = case sig of
    L (Satisfy p) -> do
      input <- ParseC get
      case input of
        c:cs | p c -> c <$ ctx <$ ParseC (put cs)
        _          -> empty
    R other       -> ParseC (alg (runParseC . hdl) (R other) ctx)
  {-# INLINE alg #-}


expr :: (Alternative m, Has Cut sig m, Has Symbol sig m) => m Int
expr = do
  i <- term
  call ((i +) <$ char '+' <* cut <*> expr
    <|> pure i)

term :: (Alternative m, Has Cut sig m, Has Symbol sig m) => m Int
term = do
  i <- factor
  call ((i *) <$ char '*' <* cut <*> term
    <|> pure i)

factor :: (Alternative m, Has Cut sig m, Has Symbol sig m) => m Int
factor
  =   read <$> some digit
  <|> parens expr