{-# LANGUAGE DataKinds, DuplicateRecordFields, FlexibleContexts, FlexibleInstances,
             MultiParamTypeClasses, OverloadedStrings, RankNTypes,
             ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}

-- | The main export of this module is the function 'foldConstants' that folds the constants in an ISO Modula-2 AST
-- using an attribute grammar. Other exports are helper functions and attribute types that can be reused for other
-- languages or attribute grammars.

module Language.Modula2.ISO.ConstantFolder (foldConstants, ConstantFold, Environment) where

import Control.Applicative (liftA2, ZipList(ZipList, getZipList))
import Control.Arrow (first)
import Control.Monad (join)
import Data.Bits (shift)
import Data.Char (chr, ord, toUpper)
import Data.Coerce (Coercible, coerce)
import Data.Functor.Identity (Identity(..))
import Data.Int (Int32)
import Data.Foldable (fold)
import Data.List.NonEmpty (toList)
import Data.Map.Lazy (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Lazy as Map
import Data.Semigroup (Semigroup(..))
import qualified Data.Text as Text
import Foreign.Storable (sizeOf)
import Data.Text.Prettyprint.Doc (Pretty)

import qualified Rank2
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import qualified Transformation.Full.TH
import qualified Transformation.AG as AG
import Transformation.AG (Attribution(..), Atts, Inherited(..), Synthesized(..), Semantics)
import Transformation.AG.Generics (Bequether(..), Synthesizer(..), SynthesizedField(..), Auto(Auto), Mapped(..))

import qualified Language.Modula2.Abstract as Abstract hiding (Modula2)
import qualified Language.Modula2.ISO.Abstract as Abstract
import qualified Language.Modula2.AST as Report
import qualified Language.Modula2.AST as AST (Ident, QualIdent, Module(..), Export(..),
                                              ProcedureHeading(..), FieldList(..), Designator(..),
                                              Element(..), Value(..))
import qualified Language.Modula2.ISO.AST as AST
import Language.Modula2.Grammar (ParsedLexemes(Trailing))
import Language.Oberon.Abstract (coExpression, coValue)
import qualified Language.Oberon.Abstract as Oberon.Abstract
import qualified Language.Oberon.AST as Oberon.AST
import qualified Language.Oberon.ConstantFolder as Oberon.ConstantFolder
import Language.Oberon.ConstantFolder (ConstantFold(ConstantFold), Placed, Sem, Environment,
                                       InhCF(..), InhCFRoot(..), SynCF(..), SynCF',
                                       SynCFRoot(..), SynCFMod(..), SynCFMod', SynCFExp(..), SynCFDesignator(..),
                                       anyWhitespace, folded', foldedExp, foldedExp')
import Language.Modula2.ConstantFolder ()

-- | Fold the constants in the given collection of Modula-2 modules (a 'Map' of modules keyed by module name). It uses
-- the constant declarations from the modules as well as the given 'Environment' of predefined constants and
-- functions.
--
-- Note that the ISO Modula-2 'AST.Language' satisfies all constraints in the function's type signature.
foldConstants :: forall l. (Abstract.Modula2 l, Abstract.Nameable l,
                            Ord (Abstract.QualIdent l), Show (Abstract.QualIdent l),
                            Atts (Inherited (Auto ConstantFold)) (Abstract.Block l l Sem Sem) ~ InhCF l,
                            Atts (Inherited (Auto ConstantFold)) (Abstract.Definition l l Sem Sem) ~ InhCF l,
                            Atts (Inherited (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ InhCF l,
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Block l l Sem Sem)
                            ~ SynCFMod' l (Abstract.Block l l),
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Block l l Placed Placed)
                            ~ SynCFMod' l (Abstract.Block l l),
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Definition l l Sem Sem)
                            ~ SynCFMod' l (Abstract.Definition l l),
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Definition l l Placed Placed)
                            ~ SynCFMod' l (Abstract.Definition l l),
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ SynCFExp l l,
                            Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Placed Placed)
                            ~ SynCFExp l l,
                            Full.Functor (Auto ConstantFold) (Abstract.Block l l),
                            Full.Functor (Auto ConstantFold) (Abstract.Definition l l),
                            Full.Functor (Auto ConstantFold) (Abstract.Expression l l))
              => Environment l -> AST.Module l l Placed Placed -> AST.Module l l Placed Placed
foldConstants :: forall l.
(Modula2 l, Nameable l, Ord (QualIdent l), Show (QualIdent l),
 Atts (Inherited (Auto ConstantFold)) (Block l l Sem Sem) ~ InhCF l,
 Atts (Inherited (Auto ConstantFold)) (Definition l l Sem Sem)
 ~ InhCF l,
 Atts (Inherited (Auto ConstantFold)) (Expression l l Sem Sem)
 ~ InhCF l,
 Atts (Synthesized (Auto ConstantFold)) (Block l l Sem Sem)
 ~ SynCFMod' l (Block l l),
 Atts (Synthesized (Auto ConstantFold)) (Block l l Placed Placed)
 ~ SynCFMod' l (Block l l),
 Atts (Synthesized (Auto ConstantFold)) (Definition l l Sem Sem)
 ~ SynCFMod' l (Definition l l),
 Atts
   (Synthesized (Auto ConstantFold)) (Definition l l Placed Placed)
 ~ SynCFMod' l (Definition l l),
 Atts (Synthesized (Auto ConstantFold)) (Expression l l Sem Sem)
 ~ SynCFExp l l,
 Atts
   (Synthesized (Auto ConstantFold)) (Expression l l Placed Placed)
 ~ SynCFExp l l,
 Functor (Auto ConstantFold) (Block l l),
 Functor (Auto ConstantFold) (Definition l l),
 Functor (Auto ConstantFold) (Expression l l)) =>
Environment l
-> Module l l Placed Placed -> Module l l Placed Placed
foldConstants Map (QualIdent l) (Maybe (Value l l Placed Placed))
predef Module l l Placed Placed
aModule =
   forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped
   forall a b. (a -> b) -> a -> b
$ forall l a. SynCFMod l a -> Mapped Placed a
folded (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn (forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.apply (forall t. t -> Auto t
Auto ConstantFold
ConstantFold) ((Int
0, [Lexeme] -> ParsedLexemes
Trailing [], Int
0), forall t. t -> Auto t
Auto ConstantFold
ConstantFold forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$> Module l l Placed Placed
aModule)
                  forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
`Rank2.apply`
                  forall t a. Atts (Inherited t) a -> Inherited t a
Inherited (forall l. Environment l -> Ident -> InhCF l
InhCF Map (QualIdent l) (Maybe (Value l l Placed Placed))
predef forall a. HasCallStack => a
undefined))
             :: SynCFMod' l (AST.Module l l))

newtype Modules l f' f = Modules {forall l (f' :: * -> *) (f :: * -> *).
Modules l f' f -> Map Ident (f (Module l l f' f'))
getModules :: Map AST.Ident (f (AST.Module l l f' f'))}

-- * Modules instances, TH candidates
instance (Transformation.Transformation t, Functor (Transformation.Domain t), Deep.Functor t (AST.Module l l),
          Transformation.At t (AST.Module l l (Transformation.Codomain t) (Transformation.Codomain t))) =>
         Deep.Functor t (Modules l) where
   t
t <$> :: t
-> Modules l (Domain t) (Domain t)
-> Modules l (Codomain t) (Codomain t)
<$> ~(Modules Map Ident (Domain t (Module l l (Domain t) (Domain t)))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Ident (f (Module l l f' f')) -> Modules l f' f
Modules (Domain t (Module l l (Domain t) (Domain t))
-> Codomain t (Module l l (Codomain t) (Codomain t))
mapModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Ident (Domain t (Module l l (Domain t) (Domain t)))
ms)
      where mapModule :: Domain t (Module l l (Domain t) (Domain t))
-> Codomain t (Module l l (Codomain t) (Codomain t))
mapModule Domain t (Module l l (Domain t) (Domain t))
m = t
t forall t x. At t x => t -> Domain t x -> Codomain t x
Transformation.$ ((t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Domain t (Module l l (Domain t) (Domain t))
m)

instance Rank2.Functor (Modules l f') where
   forall a. p a -> q a
f <$> :: forall (p :: * -> *) (q :: * -> *).
(forall a. p a -> q a) -> Modules l f' p -> Modules l f' q
<$> ~(Modules Map Ident (p (Module l l f' f'))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Ident (f (Module l l f' f')) -> Modules l f' f
Modules (forall a. p a -> q a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Ident (p (Module l l f' f'))
ms)

instance Rank2.Apply (Modules l f') where
   ~(Modules Map Ident ((~>) p q (Module l l f' f'))
fs) <*> :: forall (p :: * -> *) (q :: * -> *).
Modules l f' (p ~> q) -> Modules l f' p -> Modules l f' q
<*> ~(Modules Map Ident (p (Module l l f' f'))
ms) = forall l (f' :: * -> *) (f :: * -> *).
Map Ident (f (Module l l f' f')) -> Modules l f' f
Modules (forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply Map Ident ((~>) p q (Module l l f' f'))
fs Map Ident (p (Module l l f' f'))
ms)

-- * Boring attribute types
type instance Atts (Synthesized ConstantFold) (Modules l _ _) = SynCFRoot (Modules l Placed Identity)
type instance Atts (Synthesized ConstantFold) (AST.Block λ l _ _) = SynCFMod' l (AST.Block l l)
type instance Atts (Synthesized ConstantFold) (AST.Declaration full λ l _ _) = SynCFMod' l (AST.Declaration full l l)
type instance Atts (Synthesized ConstantFold) (AST.AddressedIdent λ l _ _) = SynCF' (AST.AddressedIdent l l)
type instance Atts (Synthesized ConstantFold) (AST.Type λ l _ _) = SynCF' (AST.Type l l)
type instance Atts (Synthesized ConstantFold) (AST.Expression λ l _ _) = SynCFExp λ l
type instance Atts (Synthesized ConstantFold) (AST.Item λ l _ _) = SynCF' (AST.Item l l)
type instance Atts (Synthesized ConstantFold) (AST.Statement λ l _ _) = SynCF' (AST.Statement l l)
type instance Atts (Synthesized ConstantFold) (AST.Variant λ l _ _) = SynCF' (AST.Variant l l)

type instance Atts (Inherited ConstantFold) (Modules l _ _) = InhCFRoot l
type instance Atts (Inherited ConstantFold) (AST.Block λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Declaration full λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.AddressedIdent λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Type λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Item λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Expression λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Statement λ l _ _) = InhCF l
type instance Atts (Inherited ConstantFold) (AST.Variant λ l _ _) = InhCF l

wrap :: a -> Mapped Placed a
wrap :: forall a. a -> Mapped Placed a
wrap = forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (Int
0, [Lexeme] -> ParsedLexemes
Trailing [], Int
0)

-- * Rules

instance Ord (Abstract.QualIdent l) => Attribution (Auto ConstantFold) (Modules l) Sem Placed where
   attribution :: Auto ConstantFold
-> Placed (Modules l Sem Sem)
-> Rule (Auto ConstantFold) (Modules l)
attribution Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
_, Modules Map Ident (Sem (Module l l Sem Sem))
self) (Inherited Atts (Inherited (Auto ConstantFold)) (Modules l sem Sem)
inheritance, Modules Map Ident (Synthesized (Auto ConstantFold) (Module l l sem sem))
ms) =
     (forall t a. Atts (Synthesized t) a -> Synthesized t a
Synthesized SynCFRoot{$sel:modulesFolded:SynCFRoot :: Modules l Placed Identity
modulesFolded= forall l (f' :: * -> *) (f :: * -> *).
Map Ident (f (Module l l f' f')) -> Modules l f' f
Modules (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynCFMod' l (Module l l)
-> Mapped Placed (Module l l Placed Placed)
foldedModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Ident (Synthesized (Auto ConstantFold) (Module l l sem sem))
ms)},
      forall l (f' :: * -> *) (f :: * -> *).
Map Ident (f (Module l l f' f')) -> Modules l f' f
Modules (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Ident
-> Sem (Module l l Sem Sem)
-> Inherited (Auto ConstantFold) (Module l l sem sem)
moduleInheritance Map Ident (Sem (Module l l Sem Sem))
self))
     where moduleInheritance :: Ident
-> Sem (Module l l Sem Sem)
-> Inherited (Auto ConstantFold) (Module l l sem sem)
moduleInheritance Ident
name Sem (Module l l Sem Sem)
mod = forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF{$sel:env:InhCF :: Map (QualIdent l) (Maybe (Value l l Placed Placed))
env= forall l. InhCFRoot l -> Environment l
rootEnv Atts (Inherited (Auto ConstantFold)) (Modules l sem Sem)
inheritance forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l a. SynCFMod l a -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn) Map Ident (Synthesized (Auto ConstantFold) (Module l l sem sem))
ms,
                                                        $sel:currentModule:InhCF :: Ident
currentModule= Ident
name}
           foldedModule :: SynCFMod' l (AST.Module l l) -> Mapped Placed (AST.Module l l Placed Placed)
           foldedModule :: SynCFMod' l (Module l l)
-> Mapped Placed (Module l l Placed Placed)
foldedModule = forall l a. SynCFMod l a -> Mapped Placed a
folded

instance (Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem) ~ SynCFMod' l (Abstract.Declaration l l),
          Atts (Inherited (Auto ConstantFold)) (Abstract.StatementSequence l l Sem Sem) ~ InhCF l,
          Atts (Inherited (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem) ~ InhCF l) =>
         Bequether (Auto ConstantFold) (AST.Block l l) Sem Placed where
   bequest :: forall (sem :: * -> *).
(sem ~ Sem) =>
Auto ConstantFold
-> Placed (Block l l Sem Sem)
-> Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
-> Block l l sem (Synthesized (Auto ConstantFold))
-> Block l l sem (Inherited (Auto ConstantFold))
bequest Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.Block ZipList (Sem (Declaration l l Sem Sem))
_decls Maybe (Sem (StatementSequence l l Sem Sem))
_stats) Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance (AST.Block ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
stats) =
      forall λ l (f' :: * -> *) (f :: * -> *).
ZipList (f (Declaration l l f' f'))
-> Maybe (f (StatementSequence l l f' f')) -> Block λ l f' f
AST.Block (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv)
      where newEnv :: Map (QualIdent l) (Maybe (Value l l Placed Placed))
newEnv = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall l a. SynCFMod l a -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls)
            localEnv :: InhCF l
localEnv = forall l. Environment l -> Ident -> InhCF l
InhCF (Map (QualIdent l) (Maybe (Value l l Placed Placed))
newEnv forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall l. InhCF l -> Environment l
env Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance) (forall l. InhCF l -> Ident
currentModule Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance)
   bequest Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.ExceptionHandlingBlock{}) Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance (AST.ExceptionHandlingBlock ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_stats Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_catch Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_always) =
      forall λ l (f' :: * -> *) (f :: * -> *).
ZipList (f (Declaration l l f' f'))
-> Maybe (f (StatementSequence l l f' f'))
-> Maybe (f (StatementSequence l l f' f'))
-> Maybe (f (StatementSequence l l f' f'))
-> Block λ l f' f
AST.ExceptionHandlingBlock (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Atts (Inherited t) a -> Inherited t a
Inherited InhCF l
localEnv)
      where newEnv :: Map (QualIdent l) (Maybe (Value l l Placed Placed))
newEnv = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall l a. SynCFMod l a -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls)
            localEnv :: InhCF l
localEnv = forall l. Environment l -> Ident -> InhCF l
InhCF (Map (QualIdent l) (Maybe (Value l l Placed Placed))
newEnv forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall l. InhCF l -> Environment l
env Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance) (forall l. InhCF l -> Ident
currentModule Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
inheritance)

instance (Abstract.Nameable l, k ~ Abstract.QualIdent l, v ~ Abstract.Value l l Placed Placed, Ord k,
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem)
          ~ SynCFMod' l (Abstract.Declaration l l)) =>
         SynthesizedField "moduleEnv" (Map k (Maybe v)) (Auto ConstantFold) (AST.Block l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Sem) =>
Proxy "moduleEnv"
-> Auto ConstantFold
-> Placed (Block l l Sem Sem)
-> Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
-> Block l l sem (Synthesized (Auto ConstantFold))
-> Map k (Maybe v)
synthesizedField Proxy "moduleEnv"
_ Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.Block{}) Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
_ (AST.Block ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_stats) = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall l a. SynCFMod l a -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls)
   synthesizedField Proxy "moduleEnv"
_ Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.ExceptionHandlingBlock{}) Atts (Inherited (Auto ConstantFold)) (Block l l sem sem)
_ (AST.ExceptionHandlingBlock ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_stats Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_catch Maybe
  (Synthesized (Auto ConstantFold) (StatementSequence l l sem sem))
_always) =
      forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall l a. SynCFMod l a -> Environment l
moduleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Synthesized (Auto ConstantFold) (Declaration l l sem sem))
decls)

instance (Abstract.Modula2 l, Abstract.Nameable l, k ~ Abstract.QualIdent l, Ord k, v ~ Abstract.Value l l Placed Placed,
          Abstract.Export l ~ AST.Export l, Abstract.Value l ~ AST.Value l,
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Declaration l l Sem Sem)
          ~ SynCFMod' l (Abstract.Declaration l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Type l l Sem Sem) ~ SynCF' (Abstract.Type l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.ProcedureHeading l l Sem Sem)
          ~ SynCF' (Abstract.ProcedureHeading l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.FormalParameters l l Sem Sem)
          ~ SynCF' (Abstract.FormalParameters l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Block l l Sem Sem) ~ SynCFMod' l (Abstract.Block l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.ConstExpression l l Sem Sem) ~ SynCFExp l l) =>
         SynthesizedField "moduleEnv" (Map k (Maybe v)) (Auto ConstantFold) (AST.Declaration full l l) Sem Placed where
   synthesizedField :: forall (sem :: * -> *).
(sem ~ Sem) =>
Proxy "moduleEnv"
-> Auto ConstantFold
-> Placed (Declaration full l l Sem Sem)
-> Atts
     (Inherited (Auto ConstantFold)) (Declaration full l l sem sem)
-> Declaration full l l sem (Synthesized (Auto ConstantFold))
-> Map k (Maybe v)
synthesizedField Proxy "moduleEnv"
_ Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.ConstantDeclaration IdentDef l
namedef Sem (ConstExpression l l Sem Sem)
_) Atts (Inherited (Auto ConstantFold)) (Declaration full l l sem sem)
_ (AST.ConstantDeclaration IdentDef l
_ Synthesized (Auto ConstantFold) (ConstExpression l l sem sem)
expression) =
      forall k a. k -> a -> Map k a
Map.singleton (forall l. Wirthy l => Ident -> QualIdent l
Abstract.nonQualIdent forall a b. (a -> b) -> a -> b
$ forall l. Nameable l => IdentDef l -> Ident
Abstract.getIdentDefName IdentDef l
namedef)
                    ((forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall λ l.
SynCFExp λ l -> Maybe (Placed (Value l l Placed Placed))
foldedValue forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto ConstantFold) (ConstExpression l l sem sem)
expression)
   synthesizedField Proxy "moduleEnv"
_ Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.ModuleDeclaration Ident
moduleName Maybe (Sem (ConstExpression l l Sem Sem))
_priority [Import l]
imports Maybe (Export l)
exports Sem (Block l l Sem Sem)
_body)
                    Atts (Inherited (Auto ConstantFold)) (Declaration full l l sem sem)
_ (AST.ModuleDeclaration Ident
_name Maybe
  (Synthesized (Auto ConstantFold) (ConstExpression l l sem sem))
priority [Import l]
_imports Maybe (Export l)
_exports Synthesized (Auto ConstantFold) (Block l l sem sem)
body) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Export l -> Map k (Maybe v)
exportedEnv Maybe (Export l)
exports
      where exportedEnv :: Export l -> Map k (Maybe v)
exportedEnv (AST.Export Bool
qualified NonEmpty Ident
names) =
               forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic QualIdent l -> QualIdent l
qualify (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QualIdent l]
exportList)) (forall l a. SynCFMod l a -> Environment l
moduleEnv forall a b. (a -> b) -> a -> b
$ forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto ConstantFold) (Block l l sem sem)
body))
               where exportList :: [QualIdent l]
exportList = forall l. Modula2 l => [Ident] -> Ident -> QualIdent l
Abstract.qualIdent [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
toList NonEmpty Ident
names
                     qualify :: QualIdent l -> QualIdent l
qualify QualIdent l
qname
                        | Bool
qualified,
                          Just Ident
name <- forall l. Nameable l => QualIdent l -> Maybe Ident
Abstract.getNonQualIdentName QualIdent l
qname = forall l. Modula2 l => [Ident] -> Ident -> QualIdent l
Abstract.qualIdent [Ident
moduleName] Ident
name
                        | Bool
otherwise = QualIdent l
qname
   synthesizedField Proxy "moduleEnv"
_ Auto ConstantFold
_ Placed (Declaration full l l Sem Sem)
_ Atts (Inherited (Auto ConstantFold)) (Declaration full l l sem sem)
_ Declaration full l l sem (Synthesized (Auto ConstantFold))
_ = forall a. Monoid a => a
mempty

instance (Abstract.Nameable l, Ord (Abstract.QualIdent l),
          Abstract.Expression λ ~ AST.Expression AST.Language, Abstract.QualIdent λ ~ AST.QualIdent AST.Language,
          InhCF l ~ InhCF λ,
          Pretty (AST.Value l l Identity Identity),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ SynCFExp l l,
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Element l l Sem Sem) ~ SynCF' (Abstract.Element l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Item l l Sem Sem) ~ SynCF' (Abstract.Item l l),
          Atts (Synthesized (Auto ConstantFold)) (Abstract.Designator l l Sem Sem) ~ SynCFDesignator l) =>
         Synthesizer (Auto ConstantFold) (AST.Expression λ l) Sem Placed where
   synthesis :: forall (sem :: * -> *).
(sem ~ Sem) =>
Auto ConstantFold
-> Placed (Expression λ l Sem Sem)
-> Atts (Inherited (Auto ConstantFold)) (Expression λ l sem sem)
-> Expression λ l sem (Synthesized (Auto ConstantFold))
-> Atts (Synthesized (Auto ConstantFold)) (Expression λ l sem sem)
synthesis Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, Expression λ l Sem Sem
_) Atts (Inherited (Auto ConstantFold)) (Expression λ l sem sem)
_ (AST.Remainder Synthesized (Auto ConstantFold) (Expression l l sem sem)
left Synthesized (Auto ConstantFold) (Expression l l sem sem)
right) = 
      forall λ l (f :: * -> *).
(f ~ Placed, Value l ~ Value l, Wirthy λ,
 Pretty (Value l l Identity Identity)) =>
(Int, ParsedLexemes, Int)
-> (f (Expression l l f f)
    -> f (Expression l l f f) -> Expression λ l f f)
-> (forall n. Integral n => n -> n -> n)
-> SynCFExp l l
-> SynCFExp l l
-> SynCFExp λ l
foldBinaryInteger (Int, ParsedLexemes, Int)
pos forall l (f :: * -> *) l' (f' :: * -> *).
Modula2 l =>
f (Expression l' l' f' f')
-> f (Expression l' l' f' f') -> Expression l l' f' f
Abstract.remainder forall n. Integral n => n -> n -> n
div (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto ConstantFold) (Expression l l sem sem)
left) (forall t a. Synthesized t a -> Atts (Synthesized t) a
syn Synthesized (Auto ConstantFold) (Expression l l sem sem)
right)
   synthesis Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, Expression λ l Sem Sem
_) Atts (Inherited (Auto ConstantFold)) (Expression λ l sem sem)
_ (AST.Array Maybe (QualIdent l)
itemType [Synthesized (Auto ConstantFold) (Item l l sem sem)]
dimensions) =
      SynCFExp{$sel:folded:SynCFExp :: Mapped Placed (Expression Language Language Placed Placed)
folded= forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped ((Int, ParsedLexemes, Int)
pos, forall l l' (f :: * -> *) (f' :: * -> *).
Modula2 l =>
Maybe (QualIdent l')
-> [f (Item l' l' f' f')] -> Expression l l' f' f
Abstract.array Maybe (QualIdent l)
itemType (forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (node :: (* -> *) -> (* -> *) -> *).
SynCF' node -> Mapped Placed (node Placed Placed)
folded' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Synthesized (Auto ConstantFold) (Item l l sem sem)]
dimensions)),
               $sel:foldedValue:SynCFExp :: Maybe (Placed (Value Language Language Placed Placed))
foldedValue= forall a. Maybe a
Nothing}
   synthesis Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, Expression λ l Sem Sem
_) Atts (Inherited (Auto ConstantFold)) (Expression λ l sem sem)
_ (AST.Record Maybe (QualIdent l)
recordType [Synthesized (Auto ConstantFold) (Expression l l sem sem)]
fields) =
      SynCFExp{$sel:folded:SynCFExp :: Mapped Placed (Expression Language Language Placed Placed)
folded= forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped ((Int, ParsedLexemes, Int)
pos, forall l l' (f :: * -> *) (f' :: * -> *).
Modula2 l =>
Maybe (QualIdent l')
-> [f (Expression l' l' f' f')] -> Expression l l' f' f
Abstract.record Maybe (QualIdent l)
recordType (forall λ l. SynCFExp λ l -> Placed (Expression λ l Placed Placed)
foldedExp' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Synthesized (Auto ConstantFold) (Expression l l sem sem)]
fields)),
               $sel:foldedValue:SynCFExp :: Maybe (Placed (Value Language Language Placed Placed))
foldedValue= forall a. Maybe a
Nothing}
   synthesis Auto ConstantFold
_ ((Int, ParsedLexemes, Int)
pos, AST.Set Maybe (QualIdent l)
t ZipList (Sem (Element l l Sem Sem))
_elements) Atts (Inherited (Auto ConstantFold)) (Expression λ l sem sem)
_ (AST.Set Maybe (QualIdent l)
_t ZipList (Synthesized (Auto ConstantFold) (Element l l sem sem))
elements) =
      SynCFExp{$sel:folded:SynCFExp :: Mapped Placed (Expression Language Language Placed Placed)
folded= forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped ((Int, ParsedLexemes, Int)
pos, forall l l' (f :: * -> *) (f' :: * -> *).
Modula2 l =>
Maybe (QualIdent l')
-> [f (Element l' l' f' f')] -> Expression l l' f' f
Abstract.set Maybe (QualIdent l)
t (forall {k} (f :: k -> *) (a :: k). Mapped f a -> f a
getMapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (node :: (* -> *) -> (* -> *) -> *).
SynCF' node -> Mapped Placed (node Placed Placed)
folded' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Synthesized t a -> Atts (Synthesized t) a
syn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Synthesized (Auto ConstantFold) (Element l l sem sem))
elements)),
               $sel:foldedValue:SynCFExp :: Maybe (Placed (Value Language Language Placed Placed))
foldedValue= forall a. Maybe a
Nothing}
   synthesis Auto ConstantFold
t ((Int, ParsedLexemes, Int)
pos, Expression λ l Sem Sem
self) (InhCF Environment Language
environment Ident
currMod) Expression λ l sem (Synthesized (Auto ConstantFold))
synthesized =
      SynCFExp Language l -> SynCFExp Language l
fromReport (forall t (g :: (* -> *) -> (* -> *) -> *) (deep :: * -> *)
       (shallow :: * -> *) (sem :: * -> *).
(Synthesizer t g deep shallow, sem ~ Semantics t) =>
t
-> shallow (g deep deep)
-> Atts (Inherited t) (g sem sem)
-> g sem (Synthesized t)
-> Atts (Synthesized t) (g sem sem)
synthesis Auto ConstantFold
t ((Int, ParsedLexemes, Int)
pos, forall (f1 :: * -> *) (f2 :: * -> *).
Expression Language l f1 f2 -> Expression Language l f1 f2
toReport Expression λ l Sem Sem
self) (forall l. Environment l -> Ident -> InhCF l
InhCF Environment Language
environment Ident
currMod) forall a b. (a -> b) -> a -> b
$ forall (f1 :: * -> *) (f2 :: * -> *).
Expression Language l f1 f2 -> Expression Language l f1 f2
toReport Expression λ l sem (Synthesized (Auto ConstantFold))
synthesized)
      where fromJust :: forall f a (b :: * -> *) (c :: * -> *). Oberon.Abstract.Maybe3 f a b c -> f a b c
            fromJust :: forall (f :: * -> (* -> *) -> (* -> *) -> *) a (b :: * -> *)
       (c :: * -> *).
Maybe3 f a b c -> f a b c
fromJust (Oberon.Abstract.Maybe3 Maybe (f a b c)
Nothing) =
               forall a. HasCallStack => [Char] -> a
error ([Char]
"Modula-2 expression cannot be converted from ISO to Report at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int, ParsedLexemes, Int)
pos)
            fromJust (Oberon.Abstract.Maybe3 (Just f a b c
e)) = f a b c
e
            fromReport :: SynCFExp Report.Language l -> SynCFExp AST.Language l
            fromReport :: SynCFExp Language l -> SynCFExp Language l
fromReport SynCFExp{$sel:folded:SynCFExp :: forall λ l.
SynCFExp λ l -> Mapped Placed (Expression λ l Placed Placed)
folded= Mapped ((Int, ParsedLexemes, Int)
pos', Expression Language l Placed Placed
reportExpression),
                                $sel:foldedValue:SynCFExp :: forall λ l.
SynCFExp λ l -> Maybe (Placed (Value l l Placed Placed))
foldedValue= Maybe (Placed (Value l l Placed Placed))
reportValue} =
               SynCFExp{$sel:folded:SynCFExp :: Mapped Placed (Expression Language l Placed Placed)
folded= forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped ((Int, ParsedLexemes, Int)
pos', forall (f :: * -> (* -> *) -> (* -> *) -> *) a (b :: * -> *)
       (c :: * -> *).
Maybe3 f a b c -> f a b c
fromJust (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Expression l l'' f' f -> Expression l' l'' f' f
coExpression @Report.Language
                                                        @(Abstract.WirthySubsetOf AST.Language) Expression Language l Placed Placed
reportExpression)),
                        $sel:foldedValue:SynCFExp :: Maybe (Placed (Value l l Placed Placed))
foldedValue= Maybe (Placed (Value l l Placed Placed))
reportValue}
            toReport :: Abstract.Expression AST.Language l f1 f2 -> Report.Expression Report.Language l f1 f2
            toReport :: forall (f1 :: * -> *) (f2 :: * -> *).
Expression Language l f1 f2 -> Expression Language l f1 f2
toReport Expression Language l f1 f2
s = forall (f :: * -> (* -> *) -> (* -> *) -> *) a (b :: * -> *)
       (c :: * -> *).
Maybe3 f a b c -> f a b c
fromJust (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Expression l l'' f' f -> Expression l' l'' f' f
coExpression @AST.Language @(Abstract.WirthySubsetOf Report.Language) Expression Language l f1 f2
s)


foldBinaryInteger :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ,
                               Pretty (Abstract.Value l l Identity Identity)) =>
                        (Int, ParsedLexemes, Int)
                     -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f)
                     -> (forall n. Integral n => n -> n -> n)
                     -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l
foldBinaryInteger :: forall λ l (f :: * -> *).
(f ~ Placed, Value l ~ Value l, Wirthy λ,
 Pretty (Value l l Identity Identity)) =>
(Int, ParsedLexemes, Int)
-> (f (Expression l l f f)
    -> f (Expression l l f f) -> Expression λ l f f)
-> (forall n. Integral n => n -> n -> n)
-> SynCFExp l l
-> SynCFExp l l
-> SynCFExp λ l
foldBinaryInteger pos :: (Int, ParsedLexemes, Int)
pos@(Int
start, ParsedLexemes
ls, Int
end) f (Expression l l f f)
-> f (Expression l l f f) -> Expression λ l f f
node forall n. Integral n => n -> n -> n
op SynCFExp l l
l SynCFExp l l
r =
   case forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Placed (Value l l f f)
-> Placed (Value l l f f) -> Maybe (Placed (Value l l f f))
foldValues forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall λ l.
SynCFExp λ l -> Maybe (Placed (Value l l Placed Placed))
foldedValue SynCFExp l l
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall λ l.
SynCFExp λ l -> Maybe (Placed (Value l l Placed Placed))
foldedValue SynCFExp l l
r)
   of Just Placed (Value l l f f)
v -> forall λ l.
(Wirthy λ, Functor (Map Placed Identity) (Value l l),
 Pretty (Value l l Identity Identity)) =>
Placed (Value l l Placed Placed) -> SynCFExp λ l
Oberon.ConstantFolder.literalSynthesis Placed (Value l l f f)
v
      Maybe (Placed (Value l l f f))
Nothing -> SynCFExp{$sel:folded:SynCFExp :: Mapped Placed (Expression λ l Placed Placed)
folded= forall {k} (f :: k -> *) (a :: k). f a -> Mapped f a
Mapped ((Int, ParsedLexemes, Int)
pos, f (Expression l l f f)
-> f (Expression l l f f) -> Expression λ l f f
node (forall λ l. SynCFExp λ l -> Placed (Expression λ l Placed Placed)
foldedExp' SynCFExp l l
l) (forall λ l. SynCFExp λ l -> Placed (Expression λ l Placed Placed)
foldedExp' SynCFExp l l
r)),
                          $sel:foldedValue:SynCFExp :: Maybe (Placed (Value l l Placed Placed))
foldedValue= forall a. Maybe a
Nothing}
   where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f))
         foldValues :: Placed (Value l l f f)
-> Placed (Value l l f f) -> Maybe (Placed (Value l l f f))
foldValues ((Int, ParsedLexemes, Int)
_, AST.Integer Integer
l') ((Int
_, ParsedLexemes
ls', Int
_), AST.Integer Integer
r') = forall a. a -> Maybe a
Just ((Int
start, ParsedLexemes -> ParsedLexemes -> ParsedLexemes
anyWhitespace ParsedLexemes
ls ParsedLexemes
ls', Int
end),
                                                                              forall λ l (f' :: * -> *) (f :: * -> *). Integer -> Value λ l f' f
AST.Integer forall a b. (a -> b) -> a -> b
$ forall n. Integral n => n -> n -> n
op Integer
l' Integer
r')
         foldValues Placed (Value l l f f)
_ Placed (Value l l f f)
_ = forall a. Maybe a
Nothing