{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE MultiWayIf             #-}
{-# LANGUAGE ScopedTypeVariables    #-}

{- |
Module      : Expression.Reorder
Copyright   : (c) 2021 comp
License     : MIT
Maintainer  : onecomputer00@gmail.com
Stability   : stable
Portability : portable

Reorders expressions in a syntax tree so that prefix, postfix, and infix operator chains are correct according to their
associativity and precedence.

Get started by creating a 'SyntaxTree' instance for your syntax types.
-}
module Expression.Reorder
    ( -- * Syntax tree reordering
      SyntaxTree(..)
    , reorder
    , Node(..)
    , Validation(..)
      -- * Operator properties
    , Fixity(..)
    , Assoc(..)
    , Precedence
    , Ambiguity(..)
      -- * Example usage
      -- $example
    ) where

import Data.Bifunctor
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)

{- | Typeclass for syntax trees @t@ with ambiguity errors @e@.

The reason for the error type is because there may be different types of expressions, e.g. value expressions and pattern
matching patterns, so there is no way to return the offending expression without combining the types first.
-}
class SyntaxTree t e | t -> e where
    {- | Applies 'reorder' to all children of this node that may have expressions to reorder.

    This is usually in the form of a traversal over the children, which will aggregate errors via 'Validation'.
    -}
    reorderChildren :: t -> Validation (NonEmpty e) t

    {- | Gets the structure of a node. -}
    structureOf :: t -> Node t

    {- | Builds an error for the ambiguous expression given. -}
    makeError :: Ambiguity -> t -> e

{- | Reorders a syntax tree to have correct precedence and associativity.

Returns either the reordered tree or a list of ambiguous expression errors.
-}
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
                -- Where both sides are open.
                (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
                -- Where only the left side is open.
                (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
                -- Where only the right side is open.
                (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
                -- Both sides are closed.
                (Node t
_leftIsClosed, Node t
_rightIsClosed) -> t -> Validation (NonEmpty e) t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
expr

        goOpenBoth
            :: t             -- ^ Original expression
            -> Fixity        -- ^ Fixity of root node
            -> Fixity        -- ^ Fixity of LHS
            -> Fixity        -- ^ Fixity of RHS
            -> (t -> t -> t) -- ^ Rebuild root node
            -> t             -- ^ LHS
            -> t             -- ^ RHS
            -> (t -> t)      -- ^ Rebuild LHS with new inner RHS
            -> (t -> t)      -- ^ Rebuild RHS with new inner LHS
            -> t             -- ^ The inner RHS of LHS
            -> t             -- ^ The inner LHS of RHS
            -> 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
            -- Side precedences are equal to root, so associativity will tiebreak.
            | 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)
            -- Left-hand side has equal precedence to root, but not right-hand side.
            | 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)
            -- Similar to previous, but opposite direction.
            | 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)
            -- From here on, the two side precedences are different from the root.
            | 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
                -- Two side precedences are equal, so associativity will tiebreak.
                | 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        -- ^ Original expression
            -> Fixity   -- ^ Fixity of root node
            -> Fixity   -- ^ Fixity of LHS
            -> (t -> t) -- ^ Rebuild root node
            -> (t -> t) -- ^ Rebuild LHS with new inner RHS
            -> t        -- ^ The inner RHS of LHS
            -> 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        -- ^ Original expression
            -> Fixity   -- ^ Fixity of root node
            -> Fixity   -- ^ Fixity of RHS
            -> (t -> t) -- ^ Rebuild root node
            -> (t -> t) -- ^ Rebuild RHS with new inner LHS
            -> t        -- ^ The inner LHS of RHS
            -> 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

{- | The structure of a node in a syntax tree in regards to operations.

A non-leaf node is made up of:

* An operator (associativity and precedence for infix nodes, just precedence for unary nodes).
* The open children of the node i.e. the children that may have reordering happen.
* A rebuilding function, which replaces the children of node and rebuilds it e.g. updating source locations.

Note that the arity referred to is the number of open children, not the arity of the operation itself.
-}
data Node t
    {- | A prefix operator, where only the right-hand side is open, e.g. @-n@ or @if p then x else y@. -}
    = NodePrefix Precedence t (t -> t)
    {- | A postfix operator, where only the left-hand side is open, e.g. @obj.field@ or @xs[n]@. -}
    | NodePostfix Precedence t (t -> t)
    {- | An infix operator, where both sides are open, e.g. @x + y@ or @p ? x : y@. -}
    | NodeInfix Fixity t t (t -> t -> t)
    {- | A leaf node where expressions may be contained, but are not open, e.g. @(x + y)@ or @do { x }@. -}
    | NodeLeaf

{- | Validation applicative, similar to 'Either' but aggregates errors. -}
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

{- | The fixity of an operator. -}
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)

{- | The associativity of an operator. -}
data Assoc
    {- | Associates to the left: @(a * b) * c@. -}
    = AssocLeft
    {- | Associates to the right: @a * (b * c)@. -}
    | AssocRight
    {- | Does not associate at all: @a * b * c@ would be ambiguous. -}
    | 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)

{- | The precedence of the operator.

Higher precedence binds tighter.
-}
type Precedence = Double

{- | An ambiguity in the operator chain. -}
data Ambiguity
    {- | Multiple operators with same precedence but different associativities in a chain. -}
    = AmbiguityMismatchAssoc
    {- | Multiple non-associative infix operators in a chain e.g. @1 == 2 == 3@. -}
    | 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)

{- $example

First, we implement the 'SyntaxTree' class for our expression type:

> data Expr
>   = ExprBinary BinOp Expr Expr
>   | ExprPrefix PreOp Expr
>   | ExprTuple [Expr]
>   | ExprInt Int
>
> fixityOf :: BinOp -> Fixity
> precOf :: PreOp -> Precedence
>
> instance SyntaxTree Expr String where
>     reorderChildren expr = case expr of
>         ExprBinary op l r -> ExprBinary op <$> reorder l <*> reorder r
>         ExprPrefix op x -> ExprPrefix op <$> reorder x
>         ExprTuple xs -> ExprTuple <$> traverse reorder xs
>         _ -> pure expr
>
>     structureOf expr = case expr of
>         ExprBinary binop l r -> NodeInfix (fixityOf binop) l r (ExprBinary binop)
>         ExprPrefix preop x -> NodePrefix (precOf preop) x (ExprPrefix preop)
>         _ -> NodeLeaf
>
>     makeError err _ = show err

Writing the traversals manually for 'reorderChildren' can be tedious, but can easily be done with other libraries, such
as @types@ from @generic-lens@ or @gplate@ from @optics@.

Then, use 'reorder' to apply the reordering to a tree:

>>> reorder $ ExprBinary BinOpMul (ExprBinary BinOpAdd (ExprInt 1) (ExprInt 2)) (ExprInt 3) -- (1 + 2) * 3
ExprBinary BinOpAdd (ExprInt 1) (ExprBinary BinOpMul (ExprInt 2) (ExprInt 3))               -- 1 + (2 * 3)

If your syntax tree is annotated with e.g. source positions, you can rebuild those in the function of 'Node':

> (<~>) :: (HasSourcePos a, HasSourcePos b) => a -> b -> SourcePos
>
> structureOf (Located _ expr) = case expr of
>     ExprBinary binop l r -> NodeInfix (fixityOf binop) l r (\l' r' -> Located (l' <~> r') $ ExprBinary binop l' r')
>     ExprPrefix preop x -> NodePrefix (precOf preop) x (\x' -> Located (preop <~> x') $ ExprPrefix preop x')
>     _ -> NodeLeaf

Higher arity operations, where at most two child expressions are open, are supported; they can be treated as a prefix,
postfix, or infix operator depending on how many open child expressions there are:

> structureOf expr = case expr of
>     ExprTernary x y z -> NodeInfix ternaryFixity x z (\x' z' -> ExprTernary x' y z')   -- x ? y : z
>     ExprIfThenElse x y z -> NodePrefix ifThenElsePrec z (\z' -> ExprIfThenElse x y z') -- if x then y else z
>     ExprIndex x y -> NodePostfix indexPrec x (\x' -> ExprIndex x' y)                   -- x[y]
>     _ -> NodeLeaf
-}