{-# 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
_) = State Int (Parsed (g Parsed Parsed))
-> Int -> Parsed (g Parsed Parsed)
forall s a. State s a -> s -> a
evalState (PositionAdjustment
-> Domain
     PositionAdjustment
     (g (Domain PositionAdjustment) (Domain PositionAdjustment))
-> State Int (Parsed (g Parsed Parsed))
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 PositionAdjustment ~ Compose m f) =>
PositionAdjustment
-> Domain
     PositionAdjustment
     (g (Domain PositionAdjustment) (Domain PositionAdjustment))
-> m (f (g f f))
Full.traverse PositionAdjustment
PositionAdjustment Parsed (g Parsed Parsed)
Domain
  PositionAdjustment
  (g (Domain PositionAdjustment) (Domain PositionAdjustment))
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 = (Text, (Int, [Lexeme])) -> Text
forall {t :: * -> *} {a}.
Foldable t =>
(Text, (a, t Lexeme)) -> Text
finalize ((Text, (Int, [Lexeme])) -> Text)
-> (Parsed (g Parsed Parsed) -> (Text, (Int, [Lexeme])))
-> Parsed (g Parsed Parsed)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State (Int, [Lexeme]) Text
-> (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
forall s a. State s a -> s -> (a, s)
`runState` (Int
0, [])) (State (Int, [Lexeme]) Text -> (Text, (Int, [Lexeme])))
-> (Parsed (g Parsed Parsed) -> State (Int, [Lexeme]) Text)
-> Parsed (g Parsed Parsed)
-> (Text, (Int, [Lexeme]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap (StateT (Int, [Lexeme]) Identity) Text
-> State (Int, [Lexeme]) Text
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (StateT (Int, [Lexeme]) Identity) Text
 -> State (Int, [Lexeme]) Text)
-> (Parsed (g Parsed Parsed)
    -> Ap (StateT (Int, [Lexeme]) Identity) Text)
-> Parsed (g Parsed Parsed)
-> State (Int, [Lexeme]) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Serialization
-> Domain
     Serialization (g (Domain Serialization) (Domain Serialization))
-> Ap (StateT (Int, [Lexeme]) Identity) Text
forall m.
(Codomain Serialization ~ Const m, Monoid m) =>
Serialization
-> Domain
     Serialization (g (Domain Serialization) (Domain Serialization))
-> m
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Lexeme -> Text) -> t Lexeme -> Text
forall m a. Monoid m => (a -> m) -> t a -> m
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) = Sum Int -> Int
forall a. Sum a -> a
getSum (Parsed (g Parsed Parsed) -> Sum Int
forall {a} {c} {b}. ((a, ParsedLexemes, c), b) -> Sum Int
nodeLength Parsed (g Parsed Parsed)
root
                                                                 Sum Int -> Sum Int -> Sum Int
forall a. Semigroup a => a -> a -> a
<> (forall a. Parsed a -> Sum Int) -> g Parsed Parsed -> Sum Int
forall (p :: * -> *) m (g :: (* -> *) -> (* -> *) -> *).
(Foldable (Fold p m) g, Monoid m) =>
(forall a. p a -> m) -> g p p -> m
Transformation.Rank2.foldMap ((Int, ParsedLexemes, Int), a) -> Sum Int
forall a. Parsed a -> Sum Int
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
_) = (Lexeme -> Sum Int) -> [Lexeme] -> Sum Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> (Lexeme -> Int) -> Lexeme -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
Text.length (Text -> Int) -> (Lexeme -> Text) -> Lexeme -> Int
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
_) = Ap (StateT (Int, [Lexeme]) Identity) Text
-> Const
     (Ap (StateT (Int, [Lexeme]) Identity) Text) (g Parsed Parsed)
forall {k} a (b :: k). a -> Const a b
Const (State (Int, [Lexeme]) Text
-> Ap (StateT (Int, [Lexeme]) Identity) Text
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (State (Int, [Lexeme]) Text
 -> Ap (StateT (Int, [Lexeme]) Identity) Text)
-> State (Int, [Lexeme]) Text
-> Ap (StateT (Int, [Lexeme]) Identity) Text
forall a b. (a -> b) -> a -> b
$ ((Int, [Lexeme]) -> (Text, (Int, [Lexeme])))
-> State (Int, [Lexeme]) Text
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pos, Lexeme
l:[Lexeme]
ls <- [Lexeme]
lexemes, Text
t <- Lexeme -> Text
lexemeText Lexeme
l = (Text -> Text)
-> (Text, (Int, [Lexeme])) -> (Text, (Int, [Lexeme]))
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ((Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
t, [Lexeme]
ls))
               | Bool
otherwise = (Text
forall a. Monoid a => a
mempty, (Int
pos, [Lexeme]
nodeLexemes [Lexeme] -> [Lexeme] -> [Lexeme]
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) = State (Int, [Lexeme]) Text
-> Ap (StateT (Int, [Lexeme]) Identity) Text
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap (((Int, [Lexeme]) -> (Text, (Int, [Lexeme])))
-> State (Int, [Lexeme]) Text
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pos, Lexeme
l:[Lexeme]
ls <- [Lexeme]
lexemes, Text
t <- Lexeme -> Text
lexemeText Lexeme
l = (Text -> Text)
-> (Text, (Int, [Lexeme])) -> (Text, (Int, [Lexeme]))
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ((Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
f (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
t, [Lexeme]
ls))
               | Bool
otherwise = let (Text
t, (Int
pos', [Lexeme]
lexemes')) = State (Int, [Lexeme]) Text
-> (Int, [Lexeme]) -> (Text, (Int, [Lexeme]))
forall s a. State s a -> s -> (a, s)
runState (Ap (StateT (Int, [Lexeme]) Identity) Text
-> State (Int, [Lexeme]) Text
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (StateT (Int, [Lexeme]) Identity) Text
 -> State (Int, [Lexeme]) Text)
-> Ap (StateT (Int, [Lexeme]) Identity) Text
-> State (Int, [Lexeme]) Text
forall a b. (a -> b) -> a -> b
$ Serialization
-> g (Domain Serialization) (Domain Serialization)
-> Ap (StateT (Int, [Lexeme]) Identity) Text
forall m.
(Codomain Serialization ~ Const m, Monoid m) =>
Serialization
-> g (Domain Serialization) (Domain Serialization) -> m
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
g (Domain Serialization) (Domain Serialization)
node) (Int
pos, [Lexeme]
nodeLexemes)
                                 t' :: Text
t' = (Lexeme -> Text) -> [Lexeme] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Lexeme -> Text
lexemeText [Lexeme]
lexemes'
                             in (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t', (Int
pos' Int -> Int -> Int
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) = StateT Int Identity ((Int, ParsedLexemes, Int), g Parsed Parsed)
-> Compose (StateT Int Identity) Parsed (g Parsed Parsed)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((Int -> (((Int, ParsedLexemes, Int), g Parsed Parsed), Int))
-> StateT Int Identity ((Int, ParsedLexemes, Int), g Parsed Parsed)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
adjustment, ParsedLexemes
lexemes, Int
nodeEnd' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
adjustment), g Parsed Parsed
node),
                            Int
adjustment Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nodeEnd' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nodeEnd)
               where nodeEnd' :: Int
nodeEnd' = Int
nodeStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int, ParsedLexemes, Int), g Parsed Parsed) -> Int
forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g) =>
Parsed (g Parsed Parsed) -> Int
sourceLength ((Int, ParsedLexemes, Int), g Parsed Parsed)
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) = (Int -> (f (g f f), Int)) -> StateT Int Identity (f (g f f))
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state Int -> (f (g f f), Int)
Int -> (((Int, ParsedLexemes, Int), g f f), Int)
f
      where f :: Int -> (((Int, ParsedLexemes, Int), g f f), Int)
f Int
adjustment = (((Int
nodeStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
adjustment, ParsedLexemes
lexemes, Int
nodeEnd' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
adjustment),
                             State Int (g f f) -> Int -> g f f
forall s a. State s a -> s -> a
evalState (PositionAdjustment
-> g (Domain PositionAdjustment) (Domain PositionAdjustment)
-> State Int (g f f)
forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) (Domain t) -> m (g f f)
forall (m :: * -> *) (f :: * -> *).
(Codomain PositionAdjustment ~ Compose m f) =>
PositionAdjustment
-> g (Domain PositionAdjustment) (Domain PositionAdjustment)
-> m (g f f)
Deep.traverse PositionAdjustment
PositionAdjustment g Parsed Parsed
g (Domain PositionAdjustment) (Domain PositionAdjustment)
node) Int
adjustment),
                            Int
adjustment Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nodeEnd' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nodeEnd)
               where nodeEnd' :: Int
nodeEnd' = Int
nodeStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int, ParsedLexemes, Int), g Parsed Parsed) -> Int
forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Parsed (Sum Int)) g) =>
Parsed (g Parsed Parsed) -> Int
sourceLength ((Int, ParsedLexemes, Int), g Parsed Parsed)
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 = Fold Parsed (Sum Int)
-> Domain
     (Fold Parsed (Sum Int))
     (g (Domain (Fold Parsed (Sum Int)))
        (Domain (Fold Parsed (Sum Int))))
-> m
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