{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Silkscreen.Precedence
( -- * Printing with precedence
  PrecedencePrinter(..)
, setPrec
, prec
, assoc
, nonAssoc
, leftAssoc
, rightAssoc
, infix_
  -- * Re-exports
, module Silkscreen
) where

import Silkscreen

-- | Pretty-printing with parenthesis insertion resolving precedence.
--
-- Given:
--
-- @
-- data ArithLevel = Bottom | Add | Mult | Exp | Top
--   deriving (Eq, Ord)
--
-- (+.) :: (PrecedencePrinter p, Level p ~ ArithLevel) => p -> p -> p
-- (+.) = 'assoc' Add ('surround' ('pretty' " + "))
-- infixl 6 +.
--
-- (*.) :: (PrecedencePrinter p, Level p ~ ArithLevel) => p -> p -> p
-- (*.) = 'assoc' Mult ('surround' ('pretty' " * "))
-- infixl 7 *.
--
-- (^.) :: (PrecedencePrinter p, Level p ~ ArithLevel) => p -> p -> p
-- (^.) = 'rightAssoc' Exp Top ('surround' ('pretty' " ^ "))
-- infixr 8 ^.
-- @
--
-- >>> putDoc . runPrec Bottom $ ('pretty' "a" +. 'pretty' "b") *. 'pretty' "c" ^. ('pretty' "d" *. 'pretty' "e")
-- (a + b) * c ^ (d * e)
class Printer p => PrecedencePrinter p where
  -- | The type used to represent precedence levels. This is defined as an associated type so that consumers can use e.g. symbolic representations of their DSL’s precedence levels instead of e.g. unsemantic 'Int's.
  --
  -- This type will usually be 'Ord'ered, but this isn’t strictly required so that other means of determining precedence can be provided.
  type Level p

  -- | Print informed by the current 'Level'.
  askingPrec :: (Level p -> p) -> p

  -- | Locally change the 'Level' in a printer.
  localPrec :: (Level p -> Level p) -> p -> p

-- | Set a constant precedence.
--
-- This function does not insert parentheses, and thus should be used when inserting parentheses or otherwise resetting the precedence level.
setPrec :: PrecedencePrinter p => Level p -> p -> p
setPrec :: Level p -> p -> p
setPrec = (Level p -> Level p) -> p -> p
forall p. PrecedencePrinter p => (Level p -> Level p) -> p -> p
localPrec ((Level p -> Level p) -> p -> p)
-> (Level p -> Level p -> Level p) -> Level p -> p -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Level p -> Level p -> Level p
forall a b. a -> b -> a
const

-- | Set a constant precedence, parenthesizing in higher-precedence contexts.
prec :: (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec :: Level p -> p -> p
prec Level p
l p
d = (Level p -> p) -> p
forall p. PrecedencePrinter p => (Level p -> p) -> p
askingPrec ((Level p -> p) -> p) -> (Level p -> p) -> p
forall a b. (a -> b) -> a -> b
$ \ Level p
l' -> Level p -> p -> p
forall p. PrecedencePrinter p => Level p -> p -> p
setPrec Level p
l (Bool -> p -> p
forall p. Printer p => Bool -> p -> p
parensIf (Level p
l' Level p -> Level p -> Bool
forall a. Ord a => a -> a -> Bool
> Level p
l) p
d)


-- | Make an associative infix combinator at the given level.
assoc :: (PrecedencePrinter p, Ord (Level p)) => Level p -> (p -> p -> p) -> (p -> p -> p)
assoc :: Level p -> (p -> p -> p) -> p -> p -> p
assoc Level p
pout = Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
forall p.
(PrecedencePrinter p, Ord (Level p)) =>
Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
infix_ Level p
pout p -> p
forall a. a -> a
id p -> p
forall a. a -> a
id

-- | Make a non-associative infix combinator at the given levels for the operator itself and its operands.
nonAssoc :: (PrecedencePrinter p, Ord (Level p)) => Level p -> Level p -> (p -> p -> p) -> (p -> p -> p)
nonAssoc :: Level p -> Level p -> (p -> p -> p) -> p -> p -> p
nonAssoc Level p
pout Level p
pin = Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
forall p.
(PrecedencePrinter p, Ord (Level p)) =>
Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
infix_ Level p
pout (Level p -> p -> p
forall p. (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec Level p
pin) (Level p -> p -> p
forall p. (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec Level p
pin)

-- | Make a left-associative infix combinator at the given levels for the operator itself and its right operand.
leftAssoc :: (PrecedencePrinter p, Ord (Level p)) => Level p -> Level p -> (p -> p -> p) -> (p -> p -> p)
leftAssoc :: Level p -> Level p -> (p -> p -> p) -> p -> p -> p
leftAssoc Level p
pl Level p
pr = Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
forall p.
(PrecedencePrinter p, Ord (Level p)) =>
Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
infix_ Level p
pl p -> p
forall a. a -> a
id (Level p -> p -> p
forall p. (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec Level p
pr)

-- | Make a right-associative infix combinator at the given levels for the operator itself and its left operand.
rightAssoc :: (PrecedencePrinter p, Ord (Level p)) => Level p -> Level p -> (p -> p -> p) -> (p -> p -> p)
rightAssoc :: Level p -> Level p -> (p -> p -> p) -> p -> p -> p
rightAssoc Level p
pr Level p
pl = Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
forall p.
(PrecedencePrinter p, Ord (Level p)) =>
Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
infix_ Level p
pr (Level p -> p -> p
forall p. (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec Level p
pl) p -> p
forall a. a -> a
id

-- | Make an infix combinator at the given level for the operator itself, applying functions to either operand.
infix_ :: (PrecedencePrinter p, Ord (Level p)) => Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> (p -> p -> p)
infix_ :: Level p -> (p -> p) -> (p -> p) -> (p -> p -> p) -> p -> p -> p
infix_ Level p
p p -> p
fl p -> p
fr p -> p -> p
op p
l p
r = Level p -> p -> p
forall p. (PrecedencePrinter p, Ord (Level p)) => Level p -> p -> p
prec Level p
p (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ p -> p
fl p
l p -> p -> p
`op` p -> p
fr p
r


instance PrecedencePrinter b => PrecedencePrinter (a -> b) where
  type Level (a -> b) = Level b

  askingPrec :: (Level (a -> b) -> a -> b) -> a -> b
askingPrec Level (a -> b) -> a -> b
f = (Level b -> b) -> b
forall p. PrecedencePrinter p => (Level p -> p) -> p
askingPrec ((Level b -> b) -> b) -> (a -> Level b -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Level b -> a -> b) -> a -> Level b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Level b -> a -> b
Level (a -> b) -> a -> b
f
  localPrec :: (Level (a -> b) -> Level (a -> b)) -> (a -> b) -> a -> b
localPrec Level (a -> b) -> Level (a -> b)
f a -> b
p = (Level b -> Level b) -> b -> b
forall p. PrecedencePrinter p => (Level p -> Level p) -> p -> p
localPrec Level b -> Level b
Level (a -> b) -> Level (a -> b)
f (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
p