{-# LANGUAGE AllowAmbiguousTypes,
             MultiParamTypeClasses #-}
{-|
Module      : Parsley.Precedence
Description : The precedence parser functionality
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : stable

This module exposes the required machinery for parsing expressions given by a precedence
table. Unlike those found in [parser-combinators](https://hackage.haskell.org/package/parser-combinators-1.3.0/docs/Control-Monad-Combinators-Expr.html)
or [parsec](https://hackage.haskell.org/package/parsec-3.1.14.0/docs/Text-Parsec-Expr.html), this
implementation allows the precedence layers to change type in the table.

@since 0.1.0.0
-}
module Parsley.Precedence (module Parsley.Precedence) where

import Prelude hiding      ((<$>))
import Parsley.Alternative (choice)
import Parsley.Applicative ((<$>))
import Parsley.Fold        (chainPre, chainPost, chainl1', chainr1')
import Parsley.Internal    (WQ, Parser, Defunc(BLACK, ID))

{-|
This combinator will construct and expression parser will provided with a table of precedence along
with a terminal atom.

@since 0.1.0.0
-}
precedence :: Prec a b -> Parser a -> Parser b
precedence :: Prec a b -> Parser a -> Parser b
precedence Prec a b
NoLevel Parser a
atom = Parser a
Parser b
atom
precedence (Level Level a b
lvl Prec b b
lvls) Parser a
atom = Prec b b -> Parser b -> Parser b
forall a b. Prec a b -> Parser a -> Parser b
precedence Prec b b
lvls (Level a b -> Parser a -> Parser b
forall a a. Level a a -> Parser a -> Parser a
level Level a b
lvl Parser a
atom)
  where
    level :: Level a a -> Parser a -> Parser a
level (InfixL [Parser (a -> a -> a)]
ops Defunc (a -> a)
wrap) Parser a
atom  = Defunc (a -> a) -> Parser a -> Parser (a -> a -> a) -> Parser a
forall (rep :: Type -> Type) a b.
ParserOps rep =>
rep (a -> b) -> Parser a -> Parser (b -> a -> b) -> Parser b
chainl1' Defunc (a -> a)
wrap Parser a
atom ([Parser (a -> a -> a)] -> Parser (a -> a -> a)
forall a. [Parser a] -> Parser a
choice [Parser (a -> a -> a)]
ops)
    level (InfixR [Parser (a -> a -> a)]
ops Defunc (a -> a)
wrap) Parser a
atom  = Defunc (a -> a) -> Parser a -> Parser (a -> a -> a) -> Parser a
forall (rep :: Type -> Type) a b.
ParserOps rep =>
rep (a -> b) -> Parser a -> Parser (a -> b -> b) -> Parser b
chainr1' Defunc (a -> a)
wrap Parser a
atom ([Parser (a -> a -> a)] -> Parser (a -> a -> a)
forall a. [Parser a] -> Parser a
choice [Parser (a -> a -> a)]
ops)
    level (Prefix [Parser (a -> a)]
ops Defunc (a -> a)
wrap) Parser a
atom  = Parser (a -> a) -> Parser a -> Parser a
forall a. Parser (a -> a) -> Parser a -> Parser a
chainPre ([Parser (a -> a)] -> Parser (a -> a)
forall a. [Parser a] -> Parser a
choice [Parser (a -> a)]
ops) (Defunc (a -> a)
wrap Defunc (a -> a) -> Parser a -> Parser a
forall (rep :: Type -> Type) a b.
ParserOps rep =>
rep (a -> b) -> Parser a -> Parser b
<$> Parser a
atom)
    level (Postfix [Parser (a -> a)]
ops Defunc (a -> a)
wrap) Parser a
atom = Parser a -> Parser (a -> a) -> Parser a
forall a. Parser a -> Parser (a -> a) -> Parser a
chainPost (Defunc (a -> a)
wrap Defunc (a -> a) -> Parser a -> Parser a
forall (rep :: Type -> Type) a b.
ParserOps rep =>
rep (a -> b) -> Parser a -> Parser b
<$> Parser a
atom) ([Parser (a -> a)] -> Parser (a -> a)
forall a. [Parser a] -> Parser a
choice [Parser (a -> a)]
ops)

{-|
A simplified version of `precedence` that does not use the heterogeneous list `Prec`, but
instead requires all layers of the table to have the same type.

@since 0.1.0.0
-}
monolith :: [Level a a] -> Prec a a
monolith :: [Level a a] -> Prec a a
monolith = (Level a a -> Prec a a -> Prec a a)
-> Prec a a -> [Level a a] -> Prec a a
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Level a a -> Prec a a -> Prec a a
forall a b c. Level a b -> Prec b c -> Prec a c
Level Prec a a
forall a. Prec a a
NoLevel

{-|
A heterogeneous list that represents a precedence table so that @Prec a b@ transforms the type @a@
into @b@ via various layers of operators.

@since 0.1.0.0
-}
data Prec a b where
  NoLevel :: Prec a a
  Level :: Level a b -> Prec b c -> Prec a c

{-|
This datatype represents levels of the precedence table `Prec`, where each constructor
takes many parsers of the same level and fixity.

@since 0.1.0.0
-}
data Level a b = InfixL  [Parser (b -> a -> b)] (Defunc (a -> b)) -- ^ left-associative infix operators
               | InfixR  [Parser (a -> b -> b)] (Defunc (a -> b)) -- ^ right-associative infix operators
               | Prefix  [Parser (b -> b)]      (Defunc (a -> b)) -- ^ prefix unary operators
               | Postfix [Parser (b -> b)]      (Defunc (a -> b)) -- ^ postfix unary operators

{-|
This class provides a way of working with the t`Level` datatype without needing to
provide wrappers, or not providing `Defunc` arguments.

@since 0.1.0.0
-}
class Monolith a b c where
  -- | Used to construct a precedence level of infix left-associative operators
  infixL  :: [Parser (b -> a -> b)] -> c
  -- | Used to construct a precedence level of infix right-associative operators
  infixR  :: [Parser (a -> b -> b)] -> c
  -- | Used to construct a precedence level of prefix operators
  prefix  :: [Parser (b -> b)]      -> c
  -- | Used to construct a precedence level of postfix operators
  postfix :: [Parser (b -> b)]      -> c

{-|
This instance is used to handle monolithic types where the input and output are the same,
it does not require the wrapping function to be provided.

@since 0.1.0.0
-}
instance x ~ a => Monolith x a (Level a a) where
  infixL :: [Parser (a -> x -> a)] -> Level a a
infixL  = ([Parser (a -> a -> a)] -> Defunc (a -> a) -> Level a a)
-> Defunc (a -> a) -> [Parser (a -> a -> a)] -> Level a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Parser (a -> a -> a)] -> Defunc (a -> a) -> Level a a
forall a b. [Parser (b -> a -> b)] -> Defunc (a -> b) -> Level a b
InfixL Defunc (a -> a)
forall a1. Defunc (a1 -> a1)
ID
  infixR :: [Parser (x -> a -> a)] -> Level a a
infixR  = ([Parser (a -> a -> a)] -> Defunc (a -> a) -> Level a a)
-> Defunc (a -> a) -> [Parser (a -> a -> a)] -> Level a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Parser (a -> a -> a)] -> Defunc (a -> a) -> Level a a
forall a b. [Parser (a -> b -> b)] -> Defunc (a -> b) -> Level a b
InfixR Defunc (a -> a)
forall a1. Defunc (a1 -> a1)
ID
  prefix :: [Parser (a -> a)] -> Level a a
prefix  = ([Parser (a -> a)] -> Defunc (a -> a) -> Level a a)
-> Defunc (a -> a) -> [Parser (a -> a)] -> Level a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Parser (a -> a)] -> Defunc (a -> a) -> Level a a
forall a b. [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
Prefix Defunc (a -> a)
forall a1. Defunc (a1 -> a1)
ID
  postfix :: [Parser (a -> a)] -> Level a a
postfix = ([Parser (a -> a)] -> Defunc (a -> a) -> Level a a)
-> Defunc (a -> a) -> [Parser (a -> a)] -> Level a a
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Parser (a -> a)] -> Defunc (a -> a) -> Level a a
forall a b. [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
Postfix Defunc (a -> a)
forall a1. Defunc (a1 -> a1)
ID

{-|
This instance is used to handle non-monolithic types: i.e. where the input and output types of
a level differ.

@since 0.1.0.0
-}
instance {-# INCOHERENT #-} x ~ (WQ (a -> b) -> Level a b) => Monolith a b x where
  infixL :: [Parser (b -> a -> b)] -> x
infixL  [Parser (b -> a -> b)]
ops = [Parser (b -> a -> b)] -> Defunc (a -> b) -> Level a b
forall a b. [Parser (b -> a -> b)] -> Defunc (a -> b) -> Level a b
InfixL [Parser (b -> a -> b)]
ops (Defunc (a -> b) -> Level a b)
-> (WQ (a -> b) -> Defunc (a -> b)) -> WQ (a -> b) -> Level a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WQ (a -> b) -> Defunc (a -> b)
forall a. WQ a -> Defunc a
BLACK
  infixR :: [Parser (a -> b -> b)] -> x
infixR  [Parser (a -> b -> b)]
ops = [Parser (a -> b -> b)] -> Defunc (a -> b) -> Level a b
forall a b. [Parser (a -> b -> b)] -> Defunc (a -> b) -> Level a b
InfixR [Parser (a -> b -> b)]
ops (Defunc (a -> b) -> Level a b)
-> (WQ (a -> b) -> Defunc (a -> b)) -> WQ (a -> b) -> Level a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WQ (a -> b) -> Defunc (a -> b)
forall a. WQ a -> Defunc a
BLACK
  prefix :: [Parser (b -> b)] -> x
prefix  [Parser (b -> b)]
ops = [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
forall a b. [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
Prefix [Parser (b -> b)]
ops (Defunc (a -> b) -> Level a b)
-> (WQ (a -> b) -> Defunc (a -> b)) -> WQ (a -> b) -> Level a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WQ (a -> b) -> Defunc (a -> b)
forall a. WQ a -> Defunc a
BLACK
  postfix :: [Parser (b -> b)] -> x
postfix [Parser (b -> b)]
ops = [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
forall a b. [Parser (b -> b)] -> Defunc (a -> b) -> Level a b
Postfix [Parser (b -> b)]
ops (Defunc (a -> b) -> Level a b)
-> (WQ (a -> b) -> Defunc (a -> b)) -> WQ (a -> b) -> Level a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WQ (a -> b) -> Defunc (a -> b)
forall a. WQ a -> Defunc a
BLACK