{-# 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
_) = 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
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
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)
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
_) = 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