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

-- | 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 = forall a. Text -> NodeWrap a -> Placed a
resolvePosition Text
src ((forall a. Text -> NodeWrap a -> Placed a
resolvePosition Text
src forall (p :: * -> *) (q :: * -> *)
       (g :: (* -> *) -> (* -> *) -> *).
Functor (Map p q) g =>
(forall a. p a -> q a) -> g p p -> g q q
Rank2.<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p (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)-> ((forall p s. (Position p, FactorialMonoid s) => s -> p -> Int
Position.offset Text
src Down Int
start, ParsedLexemes
ws, forall p s. (Position p, FactorialMonoid s) => s -> p -> 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 =
   (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 (forall l.
(Modula2 l, Ord (QualIdent l)) =>
Version l -> Environment l
predefined Version Language
Report) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
   (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 (forall l.
(Modula2 l, Ord (QualIdent l)) =>
Version l -> Environment l
predefined Version Language
ISO) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent) forall a b. (a -> b) -> a -> b
$
   [(Text
"TRUE", forall a. a -> Maybe a
Just forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
Abstract.true),
    (Text
"FALSE", forall a. a -> Maybe a
Just forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
Abstract.false)]
   forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Text -> Value l l' f' f
Abstract.builtin Text
name)
predefined Version l
ISO = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall l. Wirthy l => Text -> QualIdent l
Abstract.nonQualIdent) forall a b. (a -> b) -> a -> b
$
   [(Text
"TRUE", forall a. a -> Maybe a
Just forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
Abstract.true),
    (Text
"FALSE", forall a. a -> Maybe a
Just forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
Value l l' f' f
Abstract.false)]
   forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l l' (f' :: * -> *) (f :: * -> *).
Wirthy l =>
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 = 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 (forall (m :: * -> *) s (g :: (* -> *) -> *).
(MultiParsing m, ParserInput m ~ s, GrammarConstraint m g, Eq s,
 FactorialMonoid s) =>
g m -> s -> g (ResultFunctor m)
parseComplete Grammar (Modula2Grammar Language NodeWrap) Parser Text
Grammar.modula2grammar Text
source)
parseModule Version l
ISO Text
source = 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 (forall {k} (g :: k -> *) (h :: k -> *) (p :: k).
Product g h p -> h p
Rank2.snd forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s (g :: (* -> *) -> *).
(MultiParsing m, ParserInput m ~ s, GrammarConstraint m g, Eq s,
 FactorialMonoid s) =>
g m -> s -> g (ResultFunctor m)
parseComplete Grammar (ISOGrammar Language) Parser 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 = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (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)
-}