{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings,
             ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators,
             UndecidableInstances #-}

-- | An AST traversal for adjusting the sequences of prefix and infix operator applications in the parsed and
-- resolved AST, based on their declared precedence and fixity.

module Language.Haskell.Reorganizer (Reorganization (Reorganization), reorganizeModules) where

import Control.Applicative ((<|>))
import Control.Monad.Trans.State.Strict (State, StateT(..), evalState, runState, state)
import Data.Either (partitionEithers)
import Data.Either.Validation (Validation(..), validationToEither)
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty (NonEmpty(..), fromList, toList, nonEmpty)
import Data.Functor.Const (Const)
import qualified Data.Map.Lazy as Map
import Data.Monoid (Sum)
import Data.Semigroup (sconcat)
import Data.Semigroup.Factorial (Factorial)
import Data.Semigroup.Union (UnionWith(..))
import Data.String (IsString)

import qualified Rank2
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import qualified Transformation.Rank2
import qualified Transformation.AG.Dimorphic as Di
import Text.Grampa (Ambiguous(..))
import Text.Parser.Input.Position (Position)

import qualified Language.Haskell.Abstract as Abstract
import qualified Language.Haskell.AST as AST
import qualified Language.Haskell.Extensions.AST as ExtAST
import qualified Language.Haskell.Binder as Binder
import qualified Language.Haskell.Reserializer as Reserializer
import Language.Haskell.Reserializer (Lexeme (Token, lexemeText, lexemeType), TokenType (Delimiter))

import Prelude hiding (mod, span)

-- | Transformation to reorganize the AST
data Reorganization l pos s = Reorganization

type Wrap l pos s = Binder.WithEnvironment l (Reserializer.Wrapped pos s)

type Reorganized l f = Validation (NonEmpty (Error l f))

type NestedAdjustment l pos s = Reserializer.NestedPositionAdjustment (WithAtts l) pos s

type WithAtts l = (,) (Di.Atts (Binder.Environment l) (Binder.LocalEnvironment l))

prefixMinusPrecedence :: Int
prefixMinusPrecedence :: Int
prefixMinusPrecedence = Int
6

instance Transformation.Transformation (Reorganization l pos s) where
    type Domain (Reorganization l pos s) = Wrap l pos s
    type Codomain (Reorganization l pos s) = Compose (Reorganized l (Wrap l pos s)) (Wrap l pos s)

instance {-# overlappable #-} Reorganization l pos s
         `Transformation.At` g (Wrap l pos s) (Wrap l pos s) where
  Reorganization l pos s
Reorganization $ :: Reorganization l pos s
-> Domain
     (Reorganization l pos s) (g (Wrap l pos s) (Wrap l pos s))
-> Codomain
     (Reorganization l pos s) (g (Wrap l pos s) (Wrap l pos s))
$ Domain (Reorganization l pos s) (g (Wrap l pos s) (Wrap l pos s))
x = Validation
  (NonEmpty (Error l (Wrap l pos s)))
  (Wrap l pos s (g (Wrap l pos s) (Wrap l pos s)))
-> Compose
     (Validation (NonEmpty (Error l (Wrap l pos s))))
     (Wrap l pos s)
     (g (Wrap l pos s) (Wrap l pos s))
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Wrap l pos s (g (Wrap l pos s) (Wrap l pos s))
-> Validation
     (NonEmpty (Error l (Wrap l pos s)))
     (Wrap l pos s (g (Wrap l pos s) (Wrap l pos s)))
forall e a. a -> Validation e a
Success Wrap l pos s (g (Wrap l pos s) (Wrap l pos s))
Domain (Reorganization l pos s) (g (Wrap l pos s) (Wrap l pos s))
x)

instance {-# overlaps #-} forall l pos s f.
         (Eq s, Factorial s, IsString s, Eq pos, Position pos, f ~ Wrap l pos s,
          Show pos, Show s, Show (ExtAST.Expression l l f f),
          Full.Traversable (NestedAdjustment l pos s) (ExtAST.Expression l l),
          Abstract.Rank2lyFoldable l (Const (Sum Int)),
          Abstract.Expression l ~ ExtAST.Expression l,
          Abstract.ModuleName l ~ ExtAST.ModuleName l,
          Abstract.QualifiedName l ~ ExtAST.QualifiedName l,
          Abstract.Name l ~ ExtAST.Name l) =>
         Reorganization l pos s
         `Transformation.At` ExtAST.Expression l l (Wrap l pos s) (Wrap l pos s) where
  Reorganization l pos s
_res $ :: Reorganization l pos s
-> Domain
     (Reorganization l pos s)
     (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Codomain
     (Reorganization l pos s)
     (Expression l l (Wrap l pos s) (Wrap l pos s))
$ Compose (atts :: Atts (Environment l) (LocalEnvironment l)
atts@Di.Atts{inh :: forall a b. Atts a b -> a
Di.inh= Environment l
bindings}, ((pos, ParsedLexemes s, pos), Expression l l f f)
expression) =
      let reorganizeExpression :: Reserializer.Wrapped pos s (ExtAST.Expression l l f f)
                               -> Validation (NonEmpty (Error l f)) (f (ExtAST.Expression l l f f))
          reorganizeExpression :: ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression
             ((pos, ParsedLexemes s, pos)
root,
              ExtAST.InfixExpression
                 (Compose (Atts (Environment l) (LocalEnvironment l)
env', ((pos, ParsedLexemes s, pos)
leftBranch,
                                  ExtAST.InfixExpression Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
left Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
lOp middle :: Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
middle@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
lrStart, ParsedLexemes s
_, pos
_), Expression l l (Wrap l pos s) (Wrap l pos s)
_))))))
                 f (Expression l l f f)
rOp
                 right :: f (Expression l l f f)
right@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
_, ParsedLexemes s
_, pos
rEnd), Expression l l (Wrap l pos s) (Wrap l pos s)
_))))
             | Bool -> Bool
not ((pos, ParsedLexemes s, pos) -> Bool
forall s pos.
(Eq s, IsString s) =>
(pos, ParsedLexemes s, pos) -> Bool
parenthesized (pos, ParsedLexemes s, pos)
leftBranch),
               Just (Binder.InfixDeclaration Associativity l
associativity Int
precedence Maybe (ValueBinding l)
_) <- Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
lOp,
               Just (Binder.InfixDeclaration Associativity l
associativity' Int
precedence' Maybe (ValueBinding l)
_) <- Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
rOp,
               Int
precedence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
precedence' Bool -> Bool -> Bool
|| Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
precedence' Bool -> Bool -> Bool
&& Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
forall λ. Associativity λ
ExtAST.LeftAssociative
             = if Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
precedence'
                  Bool -> Bool -> Bool
&& (Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
associativity' Bool -> Bool -> Bool
|| Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
== Associativity l
forall λ. Associativity λ
ExtAST.NonAssociative)
               then NonEmpty (Error l f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall e a. e -> Validation e a
Failure (Error l f -> NonEmpty (Error l f)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Error l f
forall l (f :: * -> *). Error l f
ContradictoryAssociativity)
               else ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos
lrStart, ParsedLexemes s
forall a. Monoid a => a
mempty, pos
rEnd), f (Expression l l f f)
-> f (Expression l l f f)
-> f (Expression l l f f)
-> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d)
-> s (Expression l l d d)
-> Expression λ l d s
ExtAST.InfixExpression f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
middle f (Expression l l f f)
rOp f (Expression l l f f)
right)
                    Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> (f (Expression l l f f)
    -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression (((pos, ParsedLexemes s, pos), Expression l l f f)
 -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> (f (Expression l l f f)
    -> ((pos, ParsedLexemes s, pos), Expression l l f f))
-> f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (pos, ParsedLexemes s, pos)
root (Expression l l f f
 -> ((pos, ParsedLexemes s, pos), Expression l l f f))
-> (f (Expression l l f f) -> Expression l l f f)
-> f (Expression l l f f)
-> ((pos, ParsedLexemes s, pos), Expression l l f f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Expression l l f f)
-> f (Expression l l f f)
-> f (Expression l l f f)
-> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d)
-> s (Expression l l d d)
-> Expression λ l d s
ExtAST.InfixExpression f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
left f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
lOp
                    Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> (f (Expression l l f f)
    -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a. a -> Validation (NonEmpty (Error l f)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (Expression l l f f)
 -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> (f (Expression l l f f) -> f (Expression l l f f))
-> f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Expression l l f f) -> f (Expression l l f f)
adjustPositions
          reorganizeExpression
             ((pos, ParsedLexemes s, pos)
root,
              ExtAST.InfixExpression
                 left :: f (Expression l l f f)
left@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
lStart, ParsedLexemes s
_, pos
_), Expression l l (Wrap l pos s) (Wrap l pos s)
_)))
                 f (Expression l l f f)
lOp
                 (Compose (Atts (Environment l) (LocalEnvironment l)
_,
                           ((pos, ParsedLexemes s, pos)
rightBranch, ExtAST.InfixExpression middle :: Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
middle@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
_, ParsedLexemes s
_, pos
rlEnd), Expression l l (Wrap l pos s) (Wrap l pos s)
_))) Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
rOp Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
right))))
             | Bool -> Bool
not ((pos, ParsedLexemes s, pos) -> Bool
forall s pos.
(Eq s, IsString s) =>
(pos, ParsedLexemes s, pos) -> Bool
parenthesized (pos, ParsedLexemes s, pos)
rightBranch),
               Just (Binder.InfixDeclaration Associativity l
associativity Int
precedence Maybe (ValueBinding l)
_) <- Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
rOp,
               Just (Binder.InfixDeclaration Associativity l
associativity' Int
precedence' Maybe (ValueBinding l)
_) <- Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
lOp,
               Int
precedence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
precedence' Bool -> Bool -> Bool
|| Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
precedence' Bool -> Bool -> Bool
&& Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
forall λ. Associativity λ
ExtAST.RightAssociative
             = if Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
precedence'
                  Bool -> Bool -> Bool
&& (Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
associativity' Bool -> Bool -> Bool
|| Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
== Associativity l
forall λ. Associativity λ
ExtAST.NonAssociative)
               then NonEmpty (Error l f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall e a. e -> Validation e a
Failure (Error l f -> NonEmpty (Error l f)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Error l f
forall l (f :: * -> *). Error l f
ContradictoryAssociativity)
               else ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos
lStart, ParsedLexemes s
forall a. Monoid a => a
mempty, pos
rlEnd), f (Expression l l f f)
-> f (Expression l l f f)
-> f (Expression l l f f)
-> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d)
-> s (Expression l l d d)
-> Expression λ l d s
ExtAST.InfixExpression f (Expression l l f f)
left f (Expression l l f f)
lOp f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
middle)
                    Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> (f (Expression l l f f)
    -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f (Expression l l f f)
l-> ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos, ParsedLexemes s, pos)
root, f (Expression l l f f)
-> f (Expression l l f f)
-> f (Expression l l f f)
-> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d)
-> s (Expression l l d d)
-> Expression λ l d s
ExtAST.InfixExpression f (Expression l l f f)
f (Expression l l f f)
l f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
rOp f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
right)
                    Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> (f (Expression l l f f)
    -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a. a -> Validation (NonEmpty (Error l f)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (Expression l l f f)
 -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> (f (Expression l l f f) -> f (Expression l l f f))
-> f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Expression l l f f) -> f (Expression l l f f)
adjustPositions
          reorganizeExpression
             ((pos, ParsedLexemes s, pos)
root,
              ExtAST.ApplyExpression
                 neg :: f (Expression l l f f)
neg@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
negStart, ParsedLexemes s
_, pos
_), ExtAST.Negate{})))
                 (Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos, ParsedLexemes s, pos)
arg, ExtAST.InfixExpression left :: Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
left@(Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
_, ParsedLexemes s
_, pos
middleEnd), Expression l l (Wrap l pos s) (Wrap l pos s)
_))) Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
op Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
right))))
             | Bool -> Bool
not ((pos, ParsedLexemes s, pos) -> Bool
forall s pos.
(Eq s, IsString s) =>
(pos, ParsedLexemes s, pos) -> Bool
parenthesized (pos, ParsedLexemes s, pos)
arg),
               Just (Binder.InfixDeclaration Associativity l
associativity Int
precedence Maybe (ValueBinding l)
_) <- Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
op,
               Int
precedence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
prefixMinusPrecedence
               Bool -> Bool -> Bool
|| Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prefixMinusPrecedence Bool -> Bool -> Bool
&& Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
forall λ. Associativity λ
ExtAST.RightAssociative
             = if Int
precedence Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prefixMinusPrecedence Bool -> Bool -> Bool
&& Associativity l
associativity Associativity l -> Associativity l -> Bool
forall a. Eq a => a -> a -> Bool
/= Associativity l
forall λ. Associativity λ
ExtAST.LeftAssociative
               then NonEmpty (Error l f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall e a. e -> Validation e a
Failure (Error l f -> NonEmpty (Error l f)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Error l f
forall l (f :: * -> *). Error l f
ContradictoryAssociativity)
               else ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos
negStart, ParsedLexemes s
forall a. Monoid a => a
mempty, pos
middleEnd), f (Expression l l f f)
-> f (Expression l l f f) -> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d) -> Expression λ l d s
ExtAST.ApplyExpression f (Expression l l f f)
neg f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
left)
                    Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> (f (Expression l l f f)
    -> Validation (NonEmpty (Error l f)) (f (Expression l l f f)))
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f (Expression l l f f)
l-> ((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos, ParsedLexemes s, pos)
root, f (Expression l l f f)
-> f (Expression l l f f)
-> f (Expression l l f f)
-> Expression l l f f
forall λ l (d :: * -> *) (s :: * -> *).
s (Expression l l d d)
-> s (Expression l l d d)
-> s (Expression l l d d)
-> Expression λ l d s
ExtAST.InfixExpression f (Expression l l f f)
f (Expression l l f f)
l f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
op f (Expression l l f f)
Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
right)
          reorganizeExpression ((pos, ParsedLexemes s, pos), Expression l l f f)
e = f (Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
forall e a. a -> Validation e a
Success ((Atts (Environment l) (LocalEnvironment l),
 ((pos, ParsedLexemes s, pos), Expression l l f f))
-> Compose
     ((,) (Atts (Environment l) (LocalEnvironment l)))
     ((,) (pos, ParsedLexemes s, pos))
     (Expression l l f f)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Atts (Environment l) (LocalEnvironment l)
atts, ((pos, ParsedLexemes s, pos), Expression l l f f)
e))
          adjustPositions :: f (ExtAST.Expression l l f f) -> f (ExtAST.Expression l l f f)
          adjustPositions :: f (Expression l l f f) -> f (Expression l l f f)
adjustPositions f (Expression l l f f)
node = State Int (f (Expression l l f f)) -> Int -> f (Expression l l f f)
forall s a. State s a -> s -> a
evalState (NestedAdjustment l pos s
-> Domain
     (NestedAdjustment l pos s)
     (Expression
        l
        l
        (Domain (NestedAdjustment l pos s))
        (Domain (NestedAdjustment l pos s)))
-> State Int (f (Expression l l f f))
forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
forall (m :: * -> *) (f :: * -> *).
(Codomain (NestedAdjustment l pos s) ~ Compose m f) =>
NestedAdjustment l pos s
-> Domain
     (NestedAdjustment l pos s)
     (Expression
        l
        l
        (Domain (NestedAdjustment l pos s))
        (Domain (NestedAdjustment l pos s)))
-> m (f (Expression l l f f))
Full.traverse NestedAdjustment l pos s
forall (f :: * -> *) pos s. NestedPositionAdjustment f pos s
Reserializer.NestedPositionAdjustment f (Expression l l f f)
Domain
  (NestedAdjustment l pos s)
  (Expression
     l
     l
     (Domain (NestedAdjustment l pos s))
     (Domain (NestedAdjustment l pos s)))
node) Int
0
          resolve :: Compose
  ((,) (Atts (Environment l) (LocalEnvironment l)))
  ((,) (pos, ParsedLexemes s, pos))
  (Expression l l (Wrap l pos s) (Wrap l pos s))
-> Maybe (ValueBinding l)
resolve (Compose (Atts (Environment l) (LocalEnvironment l)
_, ((pos
_, ParsedLexemes s
lexemes, pos
_), ExtAST.ReferenceExpression QualifiedName l
name))) =
             QualifiedName l -> Environment l -> Maybe (ValueBinding l)
forall l.
QualifiedName l -> Environment l -> Maybe (ValueBinding l)
Binder.lookupValue QualifiedName l
QualifiedName l
name Environment l
bindings Maybe (ValueBinding l)
-> Maybe (ValueBinding l) -> Maybe (ValueBinding l)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsedLexemes s -> Maybe (ValueBinding l)
forall {s} {l}.
(Eq s, IsString s) =>
ParsedLexemes s -> Maybe (ValueBinding l)
defaultInfixDeclaration ParsedLexemes s
lexemes
      in Validation (NonEmpty (Error l f)) (f (Expression l l f f))
-> Compose
     (Validation (NonEmpty (Error l f))) f (Expression l l f f)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (((pos, ParsedLexemes s, pos), Expression l l f f)
-> Validation (NonEmpty (Error l f)) (f (Expression l l f f))
reorganizeExpression ((pos, ParsedLexemes s, pos), Expression l l f f)
expression)


--defaultInfixDeclaration :: ExtAST.QualifiedName l -> Maybe (Binder.Binding l)
defaultInfixDeclaration :: ParsedLexemes s -> Maybe (ValueBinding l)
defaultInfixDeclaration (Reserializer.Trailing [Lexeme s]
lexemes)
   | (Lexeme s -> Bool) -> [Lexeme s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Lexeme s -> Lexeme s -> Bool
forall a. Eq a => a -> a -> Bool
== Token{lexemeType :: TokenType
lexemeType= TokenType
Delimiter, lexemeText :: s
lexemeText= s
"`"}) [Lexeme s]
lexemes =
     ValueBinding l -> Maybe (ValueBinding l)
forall a. a -> Maybe a
Just (Associativity l -> Int -> Maybe (ValueBinding l) -> ValueBinding l
forall l.
Associativity l -> Int -> Maybe (ValueBinding l) -> ValueBinding l
Binder.InfixDeclaration Associativity l
forall λ. Associativity λ
AST.LeftAssociative Int
9 Maybe (ValueBinding l)
forall a. Maybe a
Nothing)
   | Bool
otherwise = Maybe (ValueBinding l)
forall a. Maybe a
Nothing

verifyInfixApplication :: (Maybe (AST.Associativity λ) -> Int -> e -> a -> a)
                       -> e -> e -> Binder.ValueBinding l -> a -> a
verifyInfixApplication :: forall λ e a l.
(Maybe (Associativity λ) -> Int -> e -> a -> a)
-> e -> e -> ValueBinding l -> a -> a
verifyInfixApplication Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg e
left e
right (Binder.InfixDeclaration Associativity l
AST.LeftAssociative Int
precedence Maybe (ValueBinding l)
_) =
   Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg (Associativity λ -> Maybe (Associativity λ)
forall a. a -> Maybe a
Just Associativity λ
forall λ. Associativity λ
AST.LeftAssociative) Int
precedence e
left (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg Maybe (Associativity λ)
forall a. Maybe a
Nothing Int
precedence e
right
verifyInfixApplication Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg e
left e
right (Binder.InfixDeclaration Associativity l
AST.RightAssociative Int
precedence Maybe (ValueBinding l)
_) =
   Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg (Associativity λ -> Maybe (Associativity λ)
forall a. a -> Maybe a
Just Associativity λ
forall λ. Associativity λ
AST.RightAssociative) Int
precedence e
right (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg Maybe (Associativity λ)
forall a. Maybe a
Nothing Int
precedence e
left
verifyInfixApplication Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg e
left e
right (Binder.InfixDeclaration Associativity l
AST.NonAssociative Int
precedence Maybe (ValueBinding l)
_) =
   Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg Maybe (Associativity λ)
forall a. Maybe a
Nothing Int
precedence e
left (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Associativity λ) -> Int -> e -> a -> a
verifyArg Maybe (Associativity λ)
forall a. Maybe a
Nothing Int
precedence e
right

modifying, parenthesized :: (Eq s, IsString s) => (pos, Reserializer.ParsedLexemes s, pos) -> Bool
modifying :: forall s pos.
(Eq s, IsString s) =>
(pos, ParsedLexemes s, pos) -> Bool
modifying (pos, ParsedLexemes s, pos)
_ = Bool
False
parenthesized :: forall s pos.
(Eq s, IsString s) =>
(pos, ParsedLexemes s, pos) -> Bool
parenthesized (pos
_, Reserializer.Trailing (Lexeme s
paren:[Lexeme s]
_), pos
_) = Lexeme s -> s
forall s. Lexeme s -> s
Reserializer.lexemeText Lexeme s
paren s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
"("
parenthesized (pos
_, Reserializer.Trailing [], pos
_) = Bool
False

data Error l f = ContradictoryAssociativity
               | ClashingImports
               | ClashingNames
               | TupleSectionWithNoOmission (NonEmpty (f (ExtAST.Expression l l f f)))
               | UnknownOperator (ExtAST.QualifiedName l)

deriving instance (Show (AST.Expression l l f f), Show (ExtAST.Expression l l f f),
                   Show (f (ExtAST.Expression l l f f)), Show (ExtAST.QualifiedName l)) => Show (Error l f)

instance Monad (Validation (NonEmpty (Error l f))) where
   Success a
s >>= :: forall a b.
Validation (NonEmpty (Error l f)) a
-> (a -> Validation (NonEmpty (Error l f)) b)
-> Validation (NonEmpty (Error l f)) b
>>= a -> Validation (NonEmpty (Error l f)) b
f = a -> Validation (NonEmpty (Error l f)) b
f a
s
   Failure NonEmpty (Error l f)
errors >>= a -> Validation (NonEmpty (Error l f)) b
_ = NonEmpty (Error l f) -> Validation (NonEmpty (Error l f)) b
forall e a. e -> Validation e a
Failure NonEmpty (Error l f)
errors

-- | Reorganize sequences of operators in the given collection of modules, a 'Map' keyed by module name. Note
-- that all class constraints in the function's type signature are satisfied by the Haskell 'AST.Language'.
reorganizeModules :: forall l pos s f. (f ~ Wrap l pos s,
                                Abstract.Haskell l,
                                Abstract.Module l l ~ AST.Module l l,
                                Abstract.ModuleName l ~ AST.ModuleName l,
                                Abstract.Export l l ~ AST.Export l l,
                                Abstract.Import l l ~ AST.Import l l,
                                Abstract.ImportSpecification l l ~ AST.ImportSpecification l l,
                                Abstract.ImportItem l l ~ AST.ImportItem l l,
                                Abstract.Members l ~ AST.Members l,
                                Abstract.Declaration l ~ ExtAST.Declaration l,
                                Abstract.QualifiedName l ~ AST.QualifiedName l,
                                Abstract.Name l ~ AST.Name l,
                                Deep.Traversable (Reorganization l pos s) (Abstract.Declaration l l),
                                Full.Traversable (Reorganization l pos s) (Abstract.Module l l),
                                Full.Traversable (Reorganization l pos s) (Abstract.Declaration l l)) =>
                  Map.Map (Abstract.ModuleName l) (f (AST.Module l l f f))
               -> Validation (NonEmpty (Abstract.ModuleName l, NonEmpty (Error l f)))
                             (Map.Map (Abstract.ModuleName l) (f (AST.Module l l f f)))
reorganizeModules :: forall l pos s (f :: * -> *).
(f ~ Wrap l pos s, Haskell l, Module l l ~ Module l l,
 ModuleName l ~ ModuleName l, Export l l ~ Export l l,
 Import l l ~ Import l l,
 ImportSpecification l l ~ ImportSpecification l l,
 ImportItem l l ~ ImportItem l l, Members l ~ Members l,
 Declaration l ~ Declaration l, QualifiedName l ~ QualifiedName l,
 Name l ~ Name l,
 Traversable (Reorganization l pos s) (Declaration l l),
 Traversable (Reorganization l pos s) (Module l l),
 Traversable (Reorganization l pos s) (Declaration l l)) =>
Map (ModuleName l) (f (Module l l f f))
-> Validation
     (NonEmpty (ModuleName l, NonEmpty (Error l f)))
     (Map (ModuleName l) (f (Module l l f f)))
reorganizeModules Map (ModuleName l) (f (Module l l f f))
modules = (ModuleName l
 -> Validation
      (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f))
 -> Validation
      (NonEmpty (ModuleName l, NonEmpty (Error l (Wrap l pos s))))
      (f (Module l l f f)))
-> Map
     (ModuleName l)
     (Validation
        (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f)))
-> Validation
     (NonEmpty (ModuleName l, NonEmpty (Error l (Wrap l pos s))))
     (Map (ModuleName l) (f (Module l l f f)))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey ModuleName l
-> Validation
     (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f))
-> Validation
     (NonEmpty (ModuleName l, NonEmpty (Error l (Wrap l pos s))))
     (f (Module l l f f))
forall {a} {b} {a}.
a -> Validation b a -> Validation (NonEmpty (a, b)) a
extractErrors Map
  (ModuleName l)
  (Validation
     (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f)))
reorganizedModules
   where reorganizedModules :: Map
  (ModuleName l)
  (Validation
     (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f)))
reorganizedModules = Reorganization l pos s
-> Domain
     (Reorganization l pos s)
     (Module
        l
        l
        (Domain (Reorganization l pos s))
        (Domain (Reorganization l pos s)))
-> Validation
     (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f))
forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
forall (m :: * -> *) (f :: * -> *).
(Codomain (Reorganization l pos s) ~ Compose m f) =>
Reorganization l pos s
-> Domain
     (Reorganization l pos s)
     (Module
        l
        l
        (Domain (Reorganization l pos s))
        (Domain (Reorganization l pos s)))
-> m (f (Module l l f f))
Full.traverse Reorganization l pos s
forall l pos s. Reorganization l pos s
Reorganization (f (Module l l f f)
 -> Validation
      (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f)))
-> Map (ModuleName l) (f (Module l l f f))
-> Map
     (ModuleName l)
     (Validation
        (NonEmpty (Error l (Wrap l pos s))) (f (Module l l f f)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (ModuleName l) (f (Module l l f f))
Map (ModuleName l) (f (Module l l f f))
modules
         extractErrors :: a -> Validation b a -> Validation (NonEmpty (a, b)) a
extractErrors a
moduleKey (Failure b
e)   = NonEmpty (a, b) -> Validation (NonEmpty (a, b)) a
forall e a. e -> Validation e a
Failure ((a
moduleKey, b
e) (a, b) -> [(a, b)] -> NonEmpty (a, b)
forall a. a -> [a] -> NonEmpty a
:| [])
         extractErrors a
_         (Success a
mod) = a -> Validation (NonEmpty (a, b)) a
forall e a. a -> Validation e a
Success a
mod

instance (Rank2.Traversable (g (Wrap l pos s)), Deep.Traversable (Reorganization l pos s) g,
          Transformation.At (Reorganization l pos s) (g (Wrap l pos s) (Wrap l pos s))) =>
         Full.Traversable (Reorganization l pos s) g where
   traverse :: forall (m :: * -> *) (f :: * -> *).
(Codomain (Reorganization l pos s) ~ Compose m f) =>
Reorganization l pos s
-> Domain
     (Reorganization l pos s)
     (g (Domain (Reorganization l pos s))
        (Domain (Reorganization l pos s)))
-> m (f (g f f))
traverse = Reorganization l pos s
-> Domain
     (Reorganization l pos s)
     (g (Domain (Reorganization l pos s))
        (Domain (Reorganization l pos s)))
-> m (f (g f f))
forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f, At t (g f f),
 Traversable (Domain t), Monad m) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
Full.traverseUpDefault