{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Expression.Reorder
(
SyntaxTree(..)
, reorder
, Node(..)
, Validation(..)
, Fixity(..)
, Assoc(..)
, Precedence
, Ambiguity(..)
) where
import Data.Bifunctor
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)
class SyntaxTree t e | t -> e where
reorderChildren :: t -> Validation (NonEmpty e) t
structureOf :: t -> Node t
makeError :: Ambiguity -> t -> e
reorder :: forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder :: t -> Validation (NonEmpty e) t
reorder = t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorderChildren (t -> Validation (NonEmpty e) t)
-> (t -> Validation (NonEmpty e) t)
-> t
-> Validation (NonEmpty e) t
forall a e b c.
(a -> Validation e b)
-> (b -> Validation e c) -> a -> Validation e c
`thenValidate` t -> Validation (NonEmpty e) t
goReorder
where
goReorder :: t -> Validation (NonEmpty e) t
goReorder :: t -> Validation (NonEmpty e) t
goReorder t
expr = case t -> Node t
forall t e. SyntaxTree t e => t -> Node t
structureOf t
expr of
Node t
NodeLeaf -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
NodePrefix Precedence
p1 t
inner t -> t
op1 -> case t -> Node t
forall t e. SyntaxTree t e => t -> Node t
structureOf t
inner of
NodeInfix Fixity
f2 t
pivot t
x t -> t -> t
op2 ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight t
expr (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p1) Fixity
f2 t -> t
op1 (t -> t -> t
`op2` t
x) t
pivot
NodePostfix Precedence
p2 t
pivot t -> t
op2 ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight t
expr (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p1) (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p2) t -> t
op1 t -> t
op2 t
pivot
Node t
_closedLeft -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
NodePostfix Precedence
p1 t
inner t -> t
op1 -> case t -> Node t
forall t e. SyntaxTree t e => t -> Node t
structureOf t
inner of
NodeInfix Fixity
f2 t
x t
pivot t -> t -> t
op2 ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft t
expr (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p1) Fixity
f2 t -> t
op1 (t
x t -> t -> t
`op2`) t
pivot
NodePrefix Precedence
p2 t
pivot t -> t
op2 ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft t
expr (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p1) (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p2) t -> t
op1 t -> t
op2 t
pivot
Node t
_closedRight -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
NodeInfix Fixity
f1 t
lhs t
rhs t -> t -> t
op1 -> case (t -> Node t
forall t e. SyntaxTree t e => t -> Node t
structureOf t
lhs, t -> Node t
forall t e. SyntaxTree t e => t -> Node t
structureOf t
rhs) of
(NodeInfix Fixity
f2 t
x t
pivotx t -> t -> t
op2, NodeInfix Fixity
f3 t
pivoty t
y t -> t -> t
op3) ->
t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth t
expr Fixity
f1 Fixity
f2 Fixity
f3 t -> t -> t
op1 t
lhs t
rhs (t
x t -> t -> t
`op2`) (t -> t -> t
`op3` t
y) t
pivotx t
pivoty
(NodeInfix Fixity
f2 t
x t
pivotx t -> t -> t
op2, NodePostfix Precedence
p3 t
pivoty t -> t
op3) ->
t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth t
expr Fixity
f1 Fixity
f2 (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p3) t -> t -> t
op1 t
lhs t
rhs (t
x t -> t -> t
`op2`) t -> t
op3 t
pivotx t
pivoty
(NodePrefix Precedence
p2 t
pivotx t -> t
op2, NodeInfix Fixity
f3 t
pivoty t
y t -> t -> t
op3) ->
t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth t
expr Fixity
f1 (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p2) Fixity
f3 t -> t -> t
op1 t
lhs t
rhs t -> t
op2 (t -> t -> t
`op3` t
y) t
pivotx t
pivoty
(NodePrefix Precedence
p2 t
pivotx t -> t
op2, NodePostfix Precedence
p3 t
pivoty t -> t
op3) ->
t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth t
expr Fixity
f1 (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p2) (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p3) t -> t -> t
op1 t
lhs t
rhs t -> t
op2 t -> t
op3 t
pivotx t
pivoty
(NodeInfix Fixity
f2 t
x t
pivot t -> t -> t
op2, Node t
_rightIsClosed) ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft t
expr Fixity
f1 Fixity
f2 (t -> t -> t
`op1` t
rhs) (t
x t -> t -> t
`op2`) t
pivot
(NodePrefix Precedence
p2 t
pivot t -> t
op2, Node t
_rightIsClosed) ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft t
expr Fixity
f1 (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocLeft Precedence
p2) (t -> t -> t
`op1` t
rhs) t -> t
op2 t
pivot
(Node t
_leftIsClosed, NodeInfix Fixity
f3 t
pivot t
y t -> t -> t
op3) ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight t
expr Fixity
f1 Fixity
f3 (t
lhs t -> t -> t
`op1`) (t -> t -> t
`op3` t
y) t
pivot
(Node t
_leftIsClosed, NodePostfix Precedence
p3 t
pivot t -> t
op3) ->
t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight t
expr Fixity
f1 (Assoc -> Precedence -> Fixity
Fixity Assoc
AssocRight Precedence
p3) (t
lhs t -> t -> t
`op1`) t -> t
op3 t
pivot
(Node t
_leftIsClosed, Node t
_rightIsClosed) -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
goOpenBoth
:: t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth :: t
-> Fixity
-> Fixity
-> Fixity
-> (t -> t -> t)
-> t
-> t
-> (t -> t)
-> (t -> t)
-> t
-> t
-> Validation (NonEmpty e) t
goOpenBoth t
expr (Fixity Assoc
a1 Precedence
p1) (Fixity Assoc
a2 Precedence
p2) (Fixity Assoc
a3 Precedence
p3) t -> t -> t
op t
lhs t
rhs t -> t
prefix t -> t
suffix t
pivotx t
pivoty
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p2 Bool -> Bool -> Bool
&& Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p3 = if
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a2 Bool -> Bool -> Bool
&& Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 Bool -> Bool -> Bool
&& Assoc
a2 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc t
expr
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a2 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc (t
lhs t -> t -> t
`op` t
pivoty)
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc (t
pivotx t -> t -> t
`op` t
rhs)
| Assoc
AssocNone <- Assoc
a1 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone t
expr
| Assoc
AssocLeft <- Assoc
a1 -> t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
lhs t -> t -> t
`op` t
pivoty)
| Assoc
AssocRight <- Assoc
a1 -> t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
rhs)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p2 = if
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a2 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc (t
lhs t -> t -> t
`op` t
pivoty)
| Assoc
AssocNone <- Assoc
a1 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone (t
lhs t -> t -> t
`op` t
pivoty)
| Assoc
AssocLeft <- Assoc
a1 -> if Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p3
then t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
else t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
lhs t -> t -> t
`op` t
pivoty)
| Assoc
AssocRight <- Assoc
a1 -> if Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p3
then t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
rhs)
else t -> t
suffix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p3 = if
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc (t
pivotx t -> t -> t
`op` t
rhs)
| Assoc
AssocNone <- Assoc
a1 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone (t
pivotx t -> t -> t
`op` t
rhs)
| Assoc
AssocRight <- Assoc
a1 -> if Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p2
then t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
else t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
rhs)
| Assoc
AssocLeft <- Assoc
a1 -> if Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p2
then t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
lhs t -> t -> t
`op` t
pivoty)
else t -> t
prefix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p2 Bool -> Bool -> Bool
&& Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p3 = if
| Precedence
p2 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p3 -> if
| Assoc
a2 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc t
expr
| Assoc
AssocNone <- Assoc
a2 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone t
expr
| Assoc
AssocLeft <- Assoc
a2 -> t -> t
suffix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Assoc
AssocRight <- Assoc
a2 -> t -> t
prefix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Precedence
p2 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p3 -> t -> t
suffix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Bool
otherwise -> t -> t
prefix (t -> t) -> (t -> t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
pivoty)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p2 Bool -> Bool -> Bool
&& Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p3 = t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
pivotx t -> t -> t
`op` t
rhs)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p2 Bool -> Bool -> Bool
&& Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p3 = t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t
lhs t -> t -> t
`op` t
pivoty)
| Bool
otherwise = t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
goOpenLeft
:: t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft :: t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenLeft t
expr (Fixity Assoc
a1 Precedence
p1) (Fixity Assoc
a2 Precedence
p2) t -> t
op t -> t
prefix t
pivot
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p2 = if
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a2 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc t
expr
| Assoc
AssocNone <- Assoc
a1 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone t
expr
| Assoc
AssocLeft <- Assoc
a1 -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
| Assoc
AssocRight <- Assoc
a1 -> t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t -> t
op t
pivot)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p2 = t -> t
prefix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t -> t
op t
pivot)
| Bool
otherwise = t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
goOpenRight
:: t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight :: t
-> Fixity
-> Fixity
-> (t -> t)
-> (t -> t)
-> t
-> Validation (NonEmpty e) t
goOpenRight t
expr (Fixity Assoc
a1 Precedence
p1) (Fixity Assoc
a3 Precedence
p3) t -> t
op t -> t
suffix t
pivot
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
p3 = if
| Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
a3 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityMismatchAssoc t
expr
| Assoc
AssocNone <- Assoc
a1 -> e -> Validation (NonEmpty e) t
forall e a. e -> Validation (NonEmpty e) a
failure (e -> Validation (NonEmpty e) t) -> e -> Validation (NonEmpty e) t
forall a b. (a -> b) -> a -> b
$ Ambiguity -> t -> e
forall t e. SyntaxTree t e => Ambiguity -> t -> e
makeError Ambiguity
AmbiguityAssocNone t
expr
| Assoc
AssocRight <- Assoc
a1 -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
| Assoc
AssocLeft <- Assoc
a1 -> t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t -> t
op t
pivot)
| Precedence
p1 Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
p3 = t -> t
suffix (t -> t) -> Validation (NonEmpty e) t -> Validation (NonEmpty e) t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> Validation (NonEmpty e) t
forall t e. SyntaxTree t e => t -> Validation (NonEmpty e) t
reorder (t -> t
op t
pivot)
| Bool
otherwise = t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr
data Node t
= NodePrefix Precedence t (t -> t)
| NodePostfix Precedence t (t -> t)
| NodeInfix Fixity t t (t -> t -> t)
| NodeLeaf
data Validation e a
= Success a
| Failure e
deriving (Int -> Validation e a -> ShowS
[Validation e a] -> ShowS
Validation e a -> String
(Int -> Validation e a -> ShowS)
-> (Validation e a -> String)
-> ([Validation e a] -> ShowS)
-> Show (Validation e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show a, Show e) => Int -> Validation e a -> ShowS
forall e a. (Show a, Show e) => [Validation e a] -> ShowS
forall e a. (Show a, Show e) => Validation e a -> String
showList :: [Validation e a] -> ShowS
$cshowList :: forall e a. (Show a, Show e) => [Validation e a] -> ShowS
show :: Validation e a -> String
$cshow :: forall e a. (Show a, Show e) => Validation e a -> String
showsPrec :: Int -> Validation e a -> ShowS
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> Validation e a -> ShowS
Show, Validation e a -> Validation e a -> Bool
(Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Bool)
-> Eq (Validation e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a.
(Eq a, Eq e) =>
Validation e a -> Validation e a -> Bool
/= :: Validation e a -> Validation e a -> Bool
$c/= :: forall e a.
(Eq a, Eq e) =>
Validation e a -> Validation e a -> Bool
== :: Validation e a -> Validation e a -> Bool
$c== :: forall e a.
(Eq a, Eq e) =>
Validation e a -> Validation e a -> Bool
Eq, (forall x. Validation e a -> Rep (Validation e a) x)
-> (forall x. Rep (Validation e a) x -> Validation e a)
-> Generic (Validation e a)
forall x. Rep (Validation e a) x -> Validation e a
forall x. Validation e a -> Rep (Validation e a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e a x. Rep (Validation e a) x -> Validation e a
forall e a x. Validation e a -> Rep (Validation e a) x
$cto :: forall e a x. Rep (Validation e a) x -> Validation e a
$cfrom :: forall e a x. Validation e a -> Rep (Validation e a) x
Generic)
instance Functor (Validation e) where
fmap :: (a -> b) -> Validation e a -> Validation e b
fmap a -> b
f (Success a
a) = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)
fmap a -> b
_ (Failure e
e) = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
instance Bifunctor Validation where
bimap :: (a -> b) -> (c -> d) -> Validation a c -> Validation b d
bimap a -> b
_ c -> d
f (Success c
x) = d -> Validation b d
forall e a. a -> Validation e a
Success (c -> d
f c
x)
bimap a -> b
f c -> d
_ (Failure a
x) = b -> Validation b d
forall e a. e -> Validation e a
Failure (a -> b
f a
x)
instance Semigroup e => Applicative (Validation e) where
pure :: a -> Validation e a
pure a
x = a -> Validation e a
forall e a. a -> Validation e a
Success a
x
Success a -> b
f <*> :: Validation e (a -> b) -> Validation e a -> Validation e b
<*> Success a
a = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)
Failure e
e <*> Success a
_ = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
Success a -> b
_ <*> Failure e
e = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
Failure e
x <*> Failure e
y = e -> Validation e b
forall e a. e -> Validation e a
Failure (e
x e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
y)
failure :: e -> Validation (NonEmpty e) a
failure :: e -> Validation (NonEmpty e) a
failure = NonEmpty e -> Validation (NonEmpty e) a
forall e a. e -> Validation e a
Failure (NonEmpty e -> Validation (NonEmpty e) a)
-> (e -> NonEmpty e) -> e -> Validation (NonEmpty e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> NonEmpty e
forall (f :: * -> *) a. Applicative f => a -> f a
pure
thenValidate :: (a -> Validation e b) -> (b -> Validation e c) -> a -> Validation e c
thenValidate :: (a -> Validation e b)
-> (b -> Validation e c) -> a -> Validation e c
thenValidate a -> Validation e b
f b -> Validation e c
g a
x = case a -> Validation e b
f a
x of
Failure e
e -> e -> Validation e c
forall e a. e -> Validation e a
Failure e
e
Success b
y -> b -> Validation e c
g b
y
data Fixity = Fixity
{ Fixity -> Assoc
fixityAssoc :: Assoc
, Fixity -> Precedence
fixityPrec :: Precedence
}
deriving (Int -> Fixity -> ShowS
[Fixity] -> ShowS
Fixity -> String
(Int -> Fixity -> ShowS)
-> (Fixity -> String) -> ([Fixity] -> ShowS) -> Show Fixity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fixity] -> ShowS
$cshowList :: [Fixity] -> ShowS
show :: Fixity -> String
$cshow :: Fixity -> String
showsPrec :: Int -> Fixity -> ShowS
$cshowsPrec :: Int -> Fixity -> ShowS
Show, Fixity -> Fixity -> Bool
(Fixity -> Fixity -> Bool)
-> (Fixity -> Fixity -> Bool) -> Eq Fixity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fixity -> Fixity -> Bool
$c/= :: Fixity -> Fixity -> Bool
== :: Fixity -> Fixity -> Bool
$c== :: Fixity -> Fixity -> Bool
Eq, (forall x. Fixity -> Rep Fixity x)
-> (forall x. Rep Fixity x -> Fixity) -> Generic Fixity
forall x. Rep Fixity x -> Fixity
forall x. Fixity -> Rep Fixity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Fixity x -> Fixity
$cfrom :: forall x. Fixity -> Rep Fixity x
Generic)
data Assoc
= AssocLeft
| AssocRight
| AssocNone
deriving (Int -> Assoc -> ShowS
[Assoc] -> ShowS
Assoc -> String
(Int -> Assoc -> ShowS)
-> (Assoc -> String) -> ([Assoc] -> ShowS) -> Show Assoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assoc] -> ShowS
$cshowList :: [Assoc] -> ShowS
show :: Assoc -> String
$cshow :: Assoc -> String
showsPrec :: Int -> Assoc -> ShowS
$cshowsPrec :: Int -> Assoc -> ShowS
Show, Assoc -> Assoc -> Bool
(Assoc -> Assoc -> Bool) -> (Assoc -> Assoc -> Bool) -> Eq Assoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assoc -> Assoc -> Bool
$c/= :: Assoc -> Assoc -> Bool
== :: Assoc -> Assoc -> Bool
$c== :: Assoc -> Assoc -> Bool
Eq, (forall x. Assoc -> Rep Assoc x)
-> (forall x. Rep Assoc x -> Assoc) -> Generic Assoc
forall x. Rep Assoc x -> Assoc
forall x. Assoc -> Rep Assoc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Assoc x -> Assoc
$cfrom :: forall x. Assoc -> Rep Assoc x
Generic)
type Precedence = Double
data Ambiguity
= AmbiguityMismatchAssoc
| AmbiguityAssocNone
deriving (Int -> Ambiguity -> ShowS
[Ambiguity] -> ShowS
Ambiguity -> String
(Int -> Ambiguity -> ShowS)
-> (Ambiguity -> String)
-> ([Ambiguity] -> ShowS)
-> Show Ambiguity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ambiguity] -> ShowS
$cshowList :: [Ambiguity] -> ShowS
show :: Ambiguity -> String
$cshow :: Ambiguity -> String
showsPrec :: Int -> Ambiguity -> ShowS
$cshowsPrec :: Int -> Ambiguity -> ShowS
Show, Ambiguity -> Ambiguity -> Bool
(Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Bool) -> Eq Ambiguity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ambiguity -> Ambiguity -> Bool
$c/= :: Ambiguity -> Ambiguity -> Bool
== :: Ambiguity -> Ambiguity -> Bool
$c== :: Ambiguity -> Ambiguity -> Bool
Eq, (forall x. Ambiguity -> Rep Ambiguity x)
-> (forall x. Rep Ambiguity x -> Ambiguity) -> Generic Ambiguity
forall x. Rep Ambiguity x -> Ambiguity
forall x. Ambiguity -> Rep Ambiguity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ambiguity x -> Ambiguity
$cfrom :: forall x. Ambiguity -> Rep Ambiguity x
Generic)