{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
             ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}

-- | This module exports functions for reserializing the parsed tree from the tokens stored with every node.

module Language.Oberon.Reserializer (adjustPositions, reserialize, sourceLength, PositionAdjustment, Serialization) where

import Control.Arrow (first)
import Control.Monad.Trans.State.Strict (State, StateT(..), evalState, runState, state)
import Data.Either (partitionEithers)
import Data.Either.Validation (Validation(..), validationToEither)
import Data.Foldable (toList)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Const (Const(..))
import Data.Monoid (Ap(Ap, getAp), Sum(Sum, getSum))
import Data.Text (Text)
import qualified Data.Text as Text

import qualified Rank2
import qualified Transformation
import qualified Transformation.Rank2
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full

import qualified Language.Oberon.Abstract as Abstract
import Language.Oberon.AST
import Language.Oberon.Grammar (ParsedLexemes(Trailing), Lexeme(..))

-- | Re-calculates the position of every node in the parse tree from the tokens stored with it and its children.
adjustPositions :: (Rank2.Foldable (g (Const (Sum Int))),
                    Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g,
                    Deep.Traversable PositionAdjustment g) => Parsed (g Parsed Parsed) -> Parsed (g Parsed Parsed)
adjustPositions :: forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g,
 Traversable PositionAdjustment g) =>
Parsed (g Parsed Parsed) -> Parsed (g Parsed Parsed)
adjustPositions node :: Parsed (g Parsed Parsed)
node@((Int
pos, ParsedLexemes
_, Int
_), g Parsed Parsed
_) = forall s a. State s a -> s -> a
evalState (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))
Full.traverse PositionAdjustment
PositionAdjustment Parsed (g Parsed Parsed)
node) Int
0

-- | Serializes the tree back into the text it was parsed from.
reserialize :: Deep.Foldable Serialization g => Parsed (g Parsed Parsed) -> Text
reserialize :: forall (g :: (* -> *) -> (* -> *) -> *).
Foldable Serialization g =>
Parsed (g Parsed Parsed) -> Text
reserialize = forall {t :: * -> *} {a}.
Foldable t =>
(Text, (a, t Lexeme)) -> Text
finalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. State s a -> s -> (a, s)
`runState` (Int
0, [])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (g :: (* -> *) -> (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> Domain t (g (Domain t) (Domain t)) -> m
Full.foldMap Serialization
Serialization
   where finalize :: (Text, (a, t Lexeme)) -> Text
finalize (Text
s, (a
_pos, t Lexeme
rest)) = Text
s forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Lexeme -> Text
lexemeText t Lexeme
rest

-- | The length of the source code parsed into the argument node
sourceLength :: (Rank2.Foldable (g (Const (Sum Int))),
                 Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) => Parsed (g Parsed Parsed) -> Int
sourceLength :: forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g) =>
Parsed (g Parsed Parsed) -> Int
sourceLength root :: Parsed (g Parsed Parsed)
root@((Int
_, Trailing [Lexeme]
rootLexemes, Int
_), g Parsed Parsed
node) = forall a. Sum a -> a
getSum (forall {a} {c} {b}. ((a, ParsedLexemes, c), b) -> Sum Int
nodeLength Parsed (g Parsed Parsed)
root
                                                                 forall a. Semigroup a => a -> a -> a
<> forall (p :: * -> *) m (g :: (* -> *) -> (* -> *) -> *).
(Foldable (Fold p m) g, Monoid m) =>
(forall a. p a -> m) -> g p p -> m
Transformation.Rank2.foldMap forall {a} {c} {b}. ((a, ParsedLexemes, c), b) -> Sum Int
nodeLength g Parsed Parsed
node)
   where nodeLength :: ((a, ParsedLexemes, c), b) -> Sum Int
nodeLength ((a
_, Trailing [Lexeme]
lexemes, c
_), b
_) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme -> Text
lexemeText) [Lexeme]
lexemes

type Parsed = (,) (Int, ParsedLexemes, Int)

-- | Transformation type used by 'reserialize'
data Serialization = Serialization
-- | Transformation type used by 'adjustPositions'
data PositionAdjustment = PositionAdjustment

instance Transformation.Transformation Serialization where
    type Domain Serialization = Parsed
    type Codomain Serialization = Const (Ap (State (Int, [Lexeme])) Text)

instance Transformation.Transformation PositionAdjustment where
    type Domain PositionAdjustment = Parsed
    type Codomain PositionAdjustment = Compose (State Int) Parsed

instance Serialization `Transformation.At` g Parsed Parsed where
   Serialization
Serialization $ :: Serialization
-> Domain Serialization (g Parsed Parsed)
-> Codomain Serialization (g Parsed Parsed)
$ ((Int
nodePos, Trailing [Lexeme]
nodeLexemes, Int
_), g Parsed Parsed
_) = forall {k} a (b :: k). a -> Const a b
Const (forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f)
      where f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
            f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos, [Lexeme]
lexemes)
               | Int
nodePos forall a. Ord a => a -> a -> Bool
> Int
pos, Lexeme
l:[Lexeme]
ls <- [Lexeme]
lexemes, Text
t <- Lexeme -> Text
lexemeText Lexeme
l = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text
t forall a. Semigroup a => a -> a -> a
<>) ((Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
t, [Lexeme]
ls))
               | Bool
otherwise = (forall a. Monoid a => a
mempty, (Int
pos, [Lexeme]
nodeLexemes forall a. Semigroup a => a -> a -> a
<> [Lexeme]
lexemes))

instance (Rank2.Foldable (g Parsed), Deep.Foldable Serialization g) => Full.Foldable Serialization g where
   foldMap :: forall m.
(Codomain Serialization ~ Const m, Monoid m) =>
Serialization
-> Domain
     Serialization (g (Domain Serialization) (Domain Serialization))
-> m
foldMap Serialization
trans ((Int
nodeStart, Trailing [Lexeme]
nodeLexemes, Int
_), g Parsed Parsed
node) = forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f)
      where f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
            f :: (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos, [Lexeme]
lexemes)
               | Int
nodeStart forall a. Ord a => a -> a -> Bool
> Int
pos, Lexeme
l:[Lexeme]
ls <- [Lexeme]
lexemes, Text
t <- Lexeme -> Text
lexemeText Lexeme
l = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text
t forall a. Semigroup a => a -> a -> a
<>) ((Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
t, [Lexeme]
ls))
               | Bool
otherwise = let (Text
t, (Int
pos', [Lexeme]
lexemes')) = forall s a. State s a -> s -> (a, s)
runState (forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp forall a b. (a -> b) -> a -> b
$ forall t (g :: (* -> *) -> (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> g (Domain t) (Domain t) -> m
Deep.foldMap Serialization
trans g Parsed Parsed
node) (Int
pos, [Lexeme]
nodeLexemes)
                                 t' :: Text
t' = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Lexeme -> Text
lexemeText [Lexeme]
lexemes'
                             in (Text
t forall a. Semigroup a => a -> a -> a
<> Text
t', (Int
pos' forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
t', [Lexeme]
lexemes))

instance (Rank2.Foldable (g (Const (Sum Int))),
          Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) =>
         PositionAdjustment `Transformation.At` g Parsed Parsed where
   PositionAdjustment
PositionAdjustment $ :: PositionAdjustment
-> Domain PositionAdjustment (g Parsed Parsed)
-> Codomain PositionAdjustment (g Parsed Parsed)
$ root :: Domain PositionAdjustment (g Parsed Parsed)
root@((Int
nodeStart, ParsedLexemes
lexemes, Int
nodeEnd), g Parsed Parsed
node) = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state Int -> (((Int, ParsedLexemes, Int), g Parsed Parsed), Int)
f)
      where f :: Int -> (((Int, ParsedLexemes, Int), g Parsed Parsed), Int)
f Int
adjustment = (((Int
nodeStart forall a. Num a => a -> a -> a
+ Int
adjustment, ParsedLexemes
lexemes, Int
nodeEnd' forall a. Num a => a -> a -> a
+ Int
adjustment), g Parsed Parsed
node),
                            Int
adjustment forall a. Num a => a -> a -> a
+ Int
nodeEnd' forall a. Num a => a -> a -> a
- Int
nodeEnd)
               where nodeEnd' :: Int
nodeEnd' = Int
nodeStart forall a. Num a => a -> a -> a
+ forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g) =>
Parsed (g Parsed Parsed) -> Int
sourceLength Domain PositionAdjustment (g Parsed Parsed)
root

instance (Rank2.Foldable (g (Const (Sum Int))),
          Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g,
          Deep.Traversable PositionAdjustment g) => Full.Traversable PositionAdjustment g where
   traverse :: forall (m :: * -> *) (f :: * -> *).
(Codomain PositionAdjustment ~ Compose m f) =>
PositionAdjustment
-> Domain
     PositionAdjustment
     (g (Domain PositionAdjustment) (Domain PositionAdjustment))
-> m (f (g f f))
traverse PositionAdjustment
PositionAdjustment root :: Domain
  PositionAdjustment
  (g (Domain PositionAdjustment) (Domain PositionAdjustment))
root@((Int
nodeStart, ParsedLexemes
lexemes, Int
nodeEnd), g Parsed Parsed
node) = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state Int -> (((Int, ParsedLexemes, Int), g f f), Int)
f
      where f :: Int -> (((Int, ParsedLexemes, Int), g f f), Int)
f Int
adjustment = (((Int
nodeStart forall a. Num a => a -> a -> a
+ Int
adjustment, ParsedLexemes
lexemes, Int
nodeEnd' forall a. Num a => a -> a -> a
+ Int
adjustment),
                             forall s a. State s a -> s -> a
evalState (forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) (Domain t) -> m (g f f)
Deep.traverse PositionAdjustment
PositionAdjustment g Parsed Parsed
node) Int
adjustment),
                            Int
adjustment forall a. Num a => a -> a -> a
+ Int
nodeEnd' forall a. Num a => a -> a -> a
- Int
nodeEnd)
               where nodeEnd' :: Int
nodeEnd' = Int
nodeStart forall a. Num a => a -> a -> a
+ forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g) =>
Parsed (g Parsed Parsed) -> Int
sourceLength Domain
  PositionAdjustment
  (g (Domain PositionAdjustment) (Domain PositionAdjustment))
root

instance (Rank2.Foldable (g Parsed),
          Deep.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g) =>
         Full.Foldable (Transformation.Rank2.Fold Parsed (Sum Int)) g where
   foldMap :: forall m.
(Codomain (Fold Parsed (Sum Int)) ~ Const m, Monoid m) =>
Fold Parsed (Sum Int)
-> Domain
     (Fold Parsed (Sum Int))
     (g (Domain (Fold Parsed (Sum Int)))
        (Domain (Fold Parsed (Sum Int))))
-> m
foldMap = forall t (g :: (* -> *) -> (* -> *) -> *) m.
(At t (g (Domain t) (Domain t)), Foldable t g,
 Codomain t ~ Const m, Foldable (Domain t), Monoid m) =>
t -> Domain t (g (Domain t) (Domain t)) -> m
Full.foldMapDownDefault