{-# Language FlexibleContexts, GADTs, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
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)
type Placed = (,) (Int, Grammar.ParsedLexemes, Int)
data Options = Options{
Options -> Bool
foldConstants :: Bool,
Options -> SomeVersion
version :: SomeVersion}
data Version l where
Report :: Version Report.Language
ISO :: Version ISO.Language
data SomeVersion where
SomeVersion :: Version l -> SomeVersion
deriving instance Show (Version l)
deriving instance Show SomeVersion
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)
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)
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
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)
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))