{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
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(..))
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
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
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)
data Serialization = Serialization
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