{-# Language FlexibleContexts, GADTs, OverloadedStrings,
             ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}

-- | The programming language Modula-2

module Language.Modula2 (parseModule, parseAndSimplifyModule, resolvePosition, resolvePositions,
                         Placed, Version(..), SomeVersion(..)) where

import qualified Language.Modula2.Abstract as Abstract
import qualified Language.Modula2.AST as Report (Language)
import qualified Language.Modula2.ISO.AST as ISO (Language)
import qualified Language.Modula2.Grammar as Grammar
import qualified Language.Modula2.ISO.Grammar as ISO.Grammar
import qualified Language.Modula2.ConstantFolder as ConstantFolder
import qualified Language.Modula2.ISO.ConstantFolder as ISO.ConstantFolder
import Language.Modula2.ConstantFolder (ConstantFold)
import Language.Modula2.Pretty ()
import Language.Modula2.ISO.Pretty ()

import qualified Language.Oberon.Reserializer as Reserializer

import qualified Rank2 as Rank2 (snd)
import Transformation.AG (Atts, Inherited, Synthesized)
import Transformation.AG.Generics (Auto)
import qualified Transformation.Rank2 as Rank2
import qualified Transformation.Full as Full
import qualified Transformation.Deep as Deep

import Control.Arrow (first)
import Control.Monad (when)
import Data.Functor.Compose (Compose(Compose, getCompose))
import qualified Data.Map.Lazy as Map
import Data.Map.Lazy (Map)
import Data.Monoid ((<>))
import Data.Text (Text, unpack)
import Data.Text.IO (readFile)
import Text.Grampa (Ambiguous, Grammar, ParseResults, parseComplete, failureDescription)
import qualified Text.Parser.Input.Position as Position
import System.Directory (doesFileExist)
import System.FilePath (FilePath, addExtension, combine, takeDirectory)

import Prelude hiding (readFile)

-- | Every node in a parsed and resolved AST is wrapped with this functor
type Placed = (,) (Int, Grammar.ParsedLexemes, Int)

-- | The modes of operation
data Options = Options{
   -- | whether to fold the constants in the parsed module
   Options -> Bool
foldConstants :: Bool,
   -- whether to check the types
   -- checkTypes :: Bool,
   -- | which version of the Modula-2 language?
   Options -> SomeVersion
version :: SomeVersion}

data Version l where
   -- | the version specified by Niklaus Wirth's ''Report on the Programming Language Modula-2''
   Report :: Version Report.Language
   -- | the version specified by the ISO standard
   ISO    :: Version ISO.Language

-- | The language version in existential container
data SomeVersion where
   SomeVersion :: Version l -> SomeVersion

deriving instance Show (Version l)
deriving instance Show SomeVersion

-- | Replace the stored positions in the entire tree with offsets from the start of the given source text
resolvePositions :: (p ~ Grammar.NodeWrap, q ~ Placed, Deep.Functor (Rank2.Map p q) g)
                 => Text -> p (g p p) -> q (g q q)
resolvePositions :: forall (p :: * -> *) (q :: * -> *)
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ NodeWrap, q ~ Placed, Functor (Map p q) g) =>
Text -> p (g p p) -> q (g q q)
resolvePositions Text
src p (g p p)
t = Text -> NodeWrap (g q q) -> Placed (g q q)
forall a. Text -> NodeWrap a -> Placed a
resolvePosition Text
src ((Text -> NodeWrap a -> Placed a
forall a. Text -> NodeWrap a -> Placed a
resolvePosition Text
src (forall {a}. p a -> q a) -> g p p -> g q q
forall (p :: * -> *) (q :: * -> *)
       (g :: (* -> *) -> (* -> *) -> *).
Functor (Map p q) g =>
(forall a. p a -> q a) -> g p p -> g q q
Rank2.<$>) (g p p -> g q q)
-> ((Down Int, ParsedLexemes, Down Int), g p p) -> NodeWrap (g q q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p (g p p)
((Down Int, ParsedLexemes, Down Int), g p p)
t)

-- | Replace the stored positions of the given node with offset from the start of the given source text
resolvePosition :: Text -> Grammar.NodeWrap a -> Placed a
resolvePosition :: forall a. Text -> NodeWrap a -> Placed a
resolvePosition Text
src = \((Down Int
start, ParsedLexemes
ws, Down Int
end), a
a)-> ((Text -> Down Int -> Int
forall p s. (Position p, FactorialMonoid s) => s -> p -> Int
forall s. FactorialMonoid s => s -> Down Int -> Int
Position.offset Text
src Down Int
start, ParsedLexemes
ws, Text -> Down Int -> Int
forall p s. (Position p, FactorialMonoid s) => s -> p -> Int
forall s. FactorialMonoid s => s -> Down Int -> Int
Position.offset Text
src Down Int
end), a
a)

-- | Parse the given text of a single module and fold constants inside it.
parseAndSimplifyModule :: (Abstract.Modula2 l, Abstract.Nameable l,
                           Full.Functor (Auto ConstantFold) (Abstract.Expression l l))
                    => Version l -> Text -> ParseResults Text [Placed (Abstract.Module l l Placed Placed)]
parseAndSimplifyModule :: forall l.
(Modula2 l, Nameable l,
 Functor (Auto ConstantFold) (Expression l l)) =>
Version l
-> Text -> ParseResults Text [Placed (Module l l Placed Placed)]
parseAndSimplifyModule Version l
Report Text
source =
   (Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Placed (Sum Int)) g,
 Traversable PositionAdjustment g) =>
Parsed (g Placed Placed) -> Parsed (g Placed Placed)
Reserializer.adjustPositions (Parsed (Module Language Language Placed Placed)
 -> Parsed (Module Language Language Placed Placed))
-> (Parsed (Module Language Language Placed Placed)
    -> Parsed (Module Language Language Placed Placed))
-> Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Environment Language
-> Module Language Language Placed Placed
-> Module Language Language Placed Placed
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
ConstantFolder.foldConstants (Version Language -> Environment Language
forall l.
(Modula2 l, Ord (QualIdent l)) =>
Version l -> Environment l
predefined Version Language
Report) (Module Language Language Placed Placed
 -> Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parsed (Module Language Language Placed Placed)
 -> Parsed (Module Language Language Placed Placed))
-> [Parsed (Module Language Language Placed Placed)]
-> [Parsed (Module Language Language Placed Placed)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
   ([Parsed (Module Language Language Placed Placed)]
 -> [Parsed (Module Language Language Placed Placed)])
-> Either
     (ParseFailure (Down Int) Text)
     [Parsed (Module Language Language Placed Placed)]
-> Either
     (ParseFailure (Down Int) Text)
     [Parsed (Module Language Language Placed Placed)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version Language
-> Text
-> ParseResults
     Text [Placed (Module Language Language Placed Placed)]
forall l.
Version l
-> Text -> ParseResults Text [Placed (Module l l Placed Placed)]
parseModule Version Language
Report Text
source
parseAndSimplifyModule Version l
ISO Text
source =
   (Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall (g :: (* -> *) -> (* -> *) -> *).
(Foldable (g (Const (Sum Int))),
 Foldable (Fold Placed (Sum Int)) g,
 Traversable PositionAdjustment g) =>
Parsed (g Placed Placed) -> Parsed (g Placed Placed)
Reserializer.adjustPositions (Parsed (Module Language Language Placed Placed)
 -> Parsed (Module Language Language Placed Placed))
-> (Parsed (Module Language Language Placed Placed)
    -> Parsed (Module Language Language Placed Placed))
-> Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Environment Language
-> Module Language Language Placed Placed
-> Module Language Language Placed Placed
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
ISO.ConstantFolder.foldConstants (Version Language -> Environment Language
forall l.
(Modula2 l, Ord (QualIdent l)) =>
Version l -> Environment l
predefined Version Language
ISO) (Module Language Language Placed Placed
 -> Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
-> Parsed (Module Language Language Placed Placed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parsed (Module Language Language Placed Placed)
 -> Parsed (Module Language Language Placed Placed))
-> [Parsed (Module Language Language Placed Placed)]
-> [Parsed (Module Language Language Placed Placed)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
   ([Parsed (Module Language Language Placed Placed)]
 -> [Parsed (Module Language Language Placed Placed)])
-> Either
     (ParseFailure (Down Int) Text)
     [Parsed (Module Language Language Placed Placed)]
-> Either
     (ParseFailure (Down Int) Text)
     [Parsed (Module Language Language Placed Placed)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version Language
-> Text
-> ParseResults
     Text [Placed (Module Language Language Placed Placed)]
forall l.
Version l
-> Text -> ParseResults Text [Placed (Module l l Placed Placed)]
parseModule Version Language
ISO Text
source

-- | The predefined environment of types, constants, and procedures for the given language version.
predefined :: (Abstract.Modula2 l, Ord (Abstract.QualIdent l)) => Version l -> ConstantFolder.Environment l
predefined :: forall l.
(Modula2 l, Ord (QualIdent l)) =>
Version l -> Environment l
predefined Version l
Report = [(QualIdent l, Maybe (Value l l Placed Placed))]
-> Map (QualIdent l) (Maybe (Value l l Placed Placed))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(QualIdent l, Maybe (Value l l Placed Placed))]
 -> Map (QualIdent l) (Maybe (Value l l Placed Placed)))
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
-> Map (QualIdent l) (Maybe (Value l l Placed Placed))
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe (Value Language Language Placed Placed))
 -> (QualIdent l, Maybe (Value l l Placed Placed)))
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> QualIdent Language)
-> (Text, Maybe (Value Language Language Placed Placed))
-> (QualIdent Language,
    Maybe (Value Language Language Placed Placed))
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 -> QualIdent Language
Text -> QualIdent Language
forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent) ([(Text, Maybe (Value Language Language Placed Placed))]
 -> [(QualIdent l, Maybe (Value l l Placed Placed))])
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
forall a b. (a -> b) -> a -> b
$
   [(Text
"TRUE", Value Language Language Placed Placed
-> Maybe (Value Language Language Placed Placed)
forall a. a -> Maybe a
Just Value Language Language Placed Placed
Value Language Language Placed Placed
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Value Language l' f' f
Abstract.true),
    (Text
"FALSE", Value Language Language Placed Placed
-> Maybe (Value Language Language Placed Placed)
forall a. a -> Maybe a
Just Value Language Language Placed Placed
Value Language Language Placed Placed
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Value Language l' f' f
Abstract.false)]
   [(Text, Maybe (Value Language Language Placed Placed))]
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(Text, Maybe (Value Language Language Placed Placed))]
forall a. [a] -> [a] -> [a]
++ (Text -> (Text, Maybe (Value Language Language Placed Placed)))
-> [Text]
-> [(Text, Maybe (Value Language Language Placed Placed))]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Maybe (Value Language Language Placed Placed))
Text -> (Text, Maybe (Value Language Language Placed Placed))
forall {l} {l'} {f' :: * -> *} {f :: * -> *}.
Wirthy l =>
Text -> (Text, Maybe (Value l l' f' f))
builtin [Text
"BITSET", Text
"BOOLEAN", Text
"CARDINAL", Text
"CHAR", Text
"INTEGER", Text
"PROC", Text
"REAL",
                   Text
"ABS", Text
"CAP", Text
"CHR", Text
"FLOAT", Text
"HIGH", Text
"MAX", Text
"MIN", Text
"ODD", Text
"ORD", Text
"TRUNC", Text
"VAL"]
   where builtin :: Text -> (Text, Maybe (Value l l' f' f))
builtin Text
name = (Text
name, Value l l' f' f -> Maybe (Value l l' f' f)
forall a. a -> Maybe a
Just (Value l l' f' f -> Maybe (Value l l' f' f))
-> Value l l' f' f -> Maybe (Value l l' f' f)
forall a b. (a -> b) -> a -> b
$ Text -> Value l l' f' f
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Text -> Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Text -> Value l l' f' f
Abstract.builtin Text
name)
predefined Version l
ISO = [(QualIdent l, Maybe (Value l l Placed Placed))]
-> Map (QualIdent l) (Maybe (Value l l Placed Placed))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(QualIdent l, Maybe (Value l l Placed Placed))]
 -> Map (QualIdent l) (Maybe (Value l l Placed Placed)))
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
-> Map (QualIdent l) (Maybe (Value l l Placed Placed))
forall a b. (a -> b) -> a -> b
$ ((Text, Maybe (Value Language Language Placed Placed))
 -> (QualIdent l, Maybe (Value l l Placed Placed)))
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> QualIdent Language)
-> (Text, Maybe (Value Language Language Placed Placed))
-> (QualIdent Language,
    Maybe (Value Language Language Placed Placed))
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 -> QualIdent Language
Text -> QualIdent Language
forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent) ([(Text, Maybe (Value Language Language Placed Placed))]
 -> [(QualIdent l, Maybe (Value l l Placed Placed))])
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(QualIdent l, Maybe (Value l l Placed Placed))]
forall a b. (a -> b) -> a -> b
$
   [(Text
"TRUE", Value Language Language Placed Placed
-> Maybe (Value Language Language Placed Placed)
forall a. a -> Maybe a
Just Value Language Language Placed Placed
Value Language Language Placed Placed
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Value Language l' f' f
Abstract.true),
    (Text
"FALSE", Value Language Language Placed Placed
-> Maybe (Value Language Language Placed Placed)
forall a. a -> Maybe a
Just Value Language Language Placed Placed
Value Language Language Placed Placed
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Value Language l' f' f
Abstract.false)]
   [(Text, Maybe (Value Language Language Placed Placed))]
-> [(Text, Maybe (Value Language Language Placed Placed))]
-> [(Text, Maybe (Value Language Language Placed Placed))]
forall a. [a] -> [a] -> [a]
++ (Text -> (Text, Maybe (Value Language Language Placed Placed)))
-> [Text]
-> [(Text, Maybe (Value Language Language Placed Placed))]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Maybe (Value Language Language Placed Placed))
Text -> (Text, Maybe (Value Language Language Placed Placed))
forall {l} {l'} {f' :: * -> *} {f :: * -> *}.
Wirthy l =>
Text -> (Text, Maybe (Value l l' f' f))
builtin [Text
"BITSET", Text
"BOOLEAN", Text
"CARDINAL", Text
"CHAR", Text
"INTEGER", Text
"PROC", Text
"REAL",
                   Text
"ABS", Text
"CAP", Text
"CHR", Text
"FLOAT", Text
"HIGH", Text
"MAX", Text
"MIN", Text
"ODD", Text
"ORD", Text
"TRUNC", Text
"VAL"]
   where builtin :: Text -> (Text, Maybe (Value l l' f' f))
builtin Text
name = (Text
name, Value l l' f' f -> Maybe (Value l l' f' f)
forall a. a -> Maybe a
Just (Value l l' f' f -> Maybe (Value l l' f' f))
-> Value l l' f' f -> Maybe (Value l l' f' f)
forall a b. (a -> b) -> a -> b
$ Text -> Value l l' f' f
forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Text -> Value l l' f' f
forall l' (f' :: * -> *) (f :: * -> *). Text -> Value l l' f' f
Abstract.builtin Text
name)

-- | Parse the given text of a single module.
parseModule :: Version l -> Text -> ParseResults Text [Placed (Abstract.Module l l Placed Placed)]
parseModule :: forall l.
Version l
-> Text -> ParseResults Text [Placed (Module l l Placed Placed)]
parseModule Version l
Report Text
source = Text
-> Modula2Grammar
     Language
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> ParseResults
     Text [Placed (Module Language Language Placed Placed)]
forall l.
Functor (Map NodeWrap Placed) (Module l l) =>
Text
-> Modula2Grammar
     l
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> ParseResults Text [Placed (Module l l Placed Placed)]
resolve Text
source (Modula2Grammar
  Language NodeWrap (Parser (Modula2Grammar Language NodeWrap) Text)
-> Text
-> Modula2Grammar
     Language
     NodeWrap
     (ResultFunctor (Parser (Modula2Grammar Language NodeWrap) Text))
forall s (g :: (* -> *) -> *).
(ParserInput (Parser (Modula2Grammar Language NodeWrap) Text) ~ s,
 GrammarConstraint
   (Parser (Modula2Grammar Language NodeWrap) Text) g,
 Eq s, FactorialMonoid s) =>
g (Parser (Modula2Grammar Language NodeWrap) Text)
-> s
-> g (ResultFunctor
        (Parser (Modula2Grammar Language NodeWrap) Text))
forall (m :: * -> *) s (g :: (* -> *) -> *).
(MultiParsing m, ParserInput m ~ s, GrammarConstraint m g, Eq s,
 FactorialMonoid s) =>
g m -> s -> g (ResultFunctor m)
parseComplete Modula2Grammar
  Language NodeWrap (Parser (Modula2Grammar Language NodeWrap) Text)
Grammar.modula2grammar Text
source)
parseModule Version l
ISO Text
source = Text
-> Modula2Grammar
     Language
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> ParseResults
     Text [Placed (Module Language Language Placed Placed)]
forall l.
Functor (Map NodeWrap Placed) (Module l l) =>
Text
-> Modula2Grammar
     l
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> ParseResults Text [Placed (Module l l Placed Placed)]
resolve Text
source (Product
  (ISOMixin Language NodeWrap)
  (Modula2Grammar Language NodeWrap)
  (Compose
     (Compose (Either (ParseFailure (Down Int) Text)) [])
     ((,) [[Lexeme]]))
-> Modula2Grammar
     Language
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
forall {k} (g :: k -> *) (h :: k -> *) (p :: k).
Product g h p -> h p
Rank2.snd (Product
   (ISOMixin Language NodeWrap)
   (Modula2Grammar Language NodeWrap)
   (Compose
      (Compose (Either (ParseFailure (Down Int) Text)) [])
      ((,) [[Lexeme]]))
 -> Modula2Grammar
      Language
      NodeWrap
      (Compose
         (Compose (Either (ParseFailure (Down Int) Text)) [])
         ((,) [[Lexeme]])))
-> Product
     (ISOMixin Language NodeWrap)
     (Modula2Grammar Language NodeWrap)
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> Modula2Grammar
     Language
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
forall a b. (a -> b) -> a -> b
$ Product
  (ISOMixin Language NodeWrap)
  (Modula2Grammar Language NodeWrap)
  (Parser (ISOGrammar Language) Text)
-> Text
-> Product
     (ISOMixin Language NodeWrap)
     (Modula2Grammar Language NodeWrap)
     (ResultFunctor (Parser (ISOGrammar Language) Text))
forall s (g :: (* -> *) -> *).
(ParserInput (Parser (ISOGrammar Language) Text) ~ s,
 GrammarConstraint (Parser (ISOGrammar Language) Text) g, Eq s,
 FactorialMonoid s) =>
g (Parser (ISOGrammar Language) Text)
-> s -> g (ResultFunctor (Parser (ISOGrammar Language) Text))
forall (m :: * -> *) s (g :: (* -> *) -> *).
(MultiParsing m, ParserInput m ~ s, GrammarConstraint m g, Eq s,
 FactorialMonoid s) =>
g m -> s -> g (ResultFunctor m)
parseComplete Product
  (ISOMixin Language NodeWrap)
  (Modula2Grammar Language NodeWrap)
  (Parser (ISOGrammar Language) Text)
ISO.Grammar.modula2ISOgrammar Text
source)

resolve :: Deep.Functor (Rank2.Map Grammar.NodeWrap Placed) (Abstract.Module l l)
        => Text
        -> Grammar.Modula2Grammar l Grammar.NodeWrap (Compose (Compose (ParseResults Text) []) ((,) [[Grammar.Lexeme]]))
        -> ParseResults Text [Placed (Abstract.Module l l Placed Placed)]
resolve :: forall l.
Functor (Map NodeWrap Placed) (Module l l) =>
Text
-> Modula2Grammar
     l
     NodeWrap
     (Compose
        (Compose (Either (ParseFailure (Down Int) Text)) [])
        ((,) [[Lexeme]]))
-> ParseResults Text [Placed (Module l l Placed Placed)]
resolve Text
source Modula2Grammar
  l
  NodeWrap
  (Compose
     (Compose (Either (ParseFailure (Down Int) Text)) [])
     ((,) [[Lexeme]]))
results = Compose
  (Either (ParseFailure (Down Int) Text))
  []
  ((Int, ParsedLexemes, Int), Module l l Placed Placed)
-> Either
     (ParseFailure (Down Int) Text)
     [((Int, ParsedLexemes, Int), Module l l Placed Placed)]
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Text
-> ((Down Int, ParsedLexemes, Down Int),
    Module l l NodeWrap NodeWrap)
-> ((Int, ParsedLexemes, Int), Module l l Placed Placed)
forall (p :: * -> *) (q :: * -> *)
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ NodeWrap, q ~ Placed, Functor (Map p q) g) =>
Text -> p (g p p) -> q (g q q)
resolvePositions Text
source (((Down Int, ParsedLexemes, Down Int),
  Module l l NodeWrap NodeWrap)
 -> ((Int, ParsedLexemes, Int), Module l l Placed Placed))
-> (([[Lexeme]],
     ((Down Int, ParsedLexemes, Down Int),
      Module l l NodeWrap NodeWrap))
    -> ((Down Int, ParsedLexemes, Down Int),
        Module l l NodeWrap NodeWrap))
-> ([[Lexeme]],
    ((Down Int, ParsedLexemes, Down Int),
     Module l l NodeWrap NodeWrap))
-> ((Int, ParsedLexemes, Int), Module l l Placed Placed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Lexeme]],
 ((Down Int, ParsedLexemes, Down Int),
  Module l l NodeWrap NodeWrap))
-> ((Down Int, ParsedLexemes, Down Int),
    Module l l NodeWrap NodeWrap)
forall a b. (a, b) -> b
snd (([[Lexeme]],
  ((Down Int, ParsedLexemes, Down Int),
   Module l l NodeWrap NodeWrap))
 -> ((Int, ParsedLexemes, Int), Module l l Placed Placed))
-> Compose
     (Either (ParseFailure (Down Int) Text))
     []
     ([[Lexeme]],
      ((Down Int, ParsedLexemes, Down Int),
       Module l l NodeWrap NodeWrap))
-> Compose
     (Either (ParseFailure (Down Int) Text))
     []
     ((Int, ParsedLexemes, Int), Module l l Placed Placed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compose
  (Compose (Either (ParseFailure (Down Int) Text)) [])
  ((,) [[Lexeme]])
  ((Down Int, ParsedLexemes, Down Int), Module l l NodeWrap NodeWrap)
-> Compose
     (Either (ParseFailure (Down Int) Text))
     []
     ([[Lexeme]],
      ((Down Int, ParsedLexemes, Down Int),
       Module l l NodeWrap NodeWrap))
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Modula2Grammar
  l
  NodeWrap
  (Compose
     (Compose (Either (ParseFailure (Down Int) Text)) [])
     ((,) [[Lexeme]]))
-> Compose
     (Compose (Either (ParseFailure (Down Int) Text)) [])
     ((,) [[Lexeme]])
     ((Down Int, ParsedLexemes, Down Int), Module l l NodeWrap NodeWrap)
forall l (f :: * -> *) (p :: * -> *).
Modula2Grammar l f p -> p (NodeWrap (Module l l f f))
Grammar.compilationUnit Modula2Grammar
  l
  NodeWrap
  (Compose
     (Compose (Either (ParseFailure (Down Int) Text)) [])
     ((,) [[Lexeme]]))
results))

{-
parseNamedModule :: FilePath -> Text -> IO (ParseResults Text [Module Language Language Placed Placed])
parseNamedModule path name =
   do let basePath = combine path (unpack name)
      isDefn <- doesFileExist (addExtension basePath "Def")
      src <- readFile (addExtension basePath $ if isDefn then "Def" else "Mod")
      return (getCompose $ resolvePositions src <$> Grammar.compilationUnit (parseComplete Grammar.modula2grammar src))

parseImportsOf :: FilePath -> Map Text (Module Language Language Placed Placed)
               -> IO (Map Text (Module Language Language Placed Placed))
parseImportsOf path modules =
   case filter (`Map.notMember` modules) moduleImports
   of [] -> return modules
      newImports -> (((modules <>) . Map.fromList . map assertSuccess) <$>
                     (traverse . traverse) (parseNamedModule path) [(p, p) | p <- newImports])
                    >>= parseImportsOf path
   where moduleImports = foldMap (fmap importedModule . importsOf) modules
         importedModule (Import _ m) = m
         importsOf (DefinitionModule _ imports _ _) = imports
         importsOf (ImplementationModule _ _ imports _) = imports
         importsOf (ProgramModule _ _ imports _) = imports
         assertSuccess (m, Left err) = error ("Parse error in module " <> unpack m)
         assertSuccess (m, Right [p]) = (m, p)
         assertSuccess (m, Right _) = error ("Ambiguous parses of module " <> unpack m)
-}