{-# Language FlexibleContexts, RecordWildCards, TypeFamilies #-}
module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModuleFile,
LanguageVersion(..), Options(..), NodeWrap, Placed) where
import Language.Oberon.AST (Language, Module(..))
import qualified Language.Oberon.Grammar as Grammar
import qualified Language.Oberon.Resolver as Resolver
import qualified Language.Oberon.Reserializer as Reserializer
import qualified Language.Oberon.ConstantFolder as ConstantFolder
import qualified Language.Oberon.TypeChecker as TypeChecker
import Language.Oberon.Resolver (NodeWrap, Placed)
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import Control.Monad (guard)
import Data.Either.Validation (Validation(..))
import Data.Functor.Compose (Compose(Compose, getCompose))
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
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(Ambiguous), Grammar, ParseResults, parseComplete, failureDescription)
import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive
import System.Directory (doesFileExist)
import System.FilePath (FilePath, addExtension, combine, takeDirectory)
import Prelude hiding (readFile)
data LanguageVersion = Oberon1 | Oberon2 deriving (LanguageVersion -> LanguageVersion -> Bool
(LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> Eq LanguageVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LanguageVersion -> LanguageVersion -> Bool
$c/= :: LanguageVersion -> LanguageVersion -> Bool
== :: LanguageVersion -> LanguageVersion -> Bool
$c== :: LanguageVersion -> LanguageVersion -> Bool
Eq, Eq LanguageVersion
Eq LanguageVersion
-> (LanguageVersion -> LanguageVersion -> Ordering)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> LanguageVersion)
-> (LanguageVersion -> LanguageVersion -> LanguageVersion)
-> Ord LanguageVersion
LanguageVersion -> LanguageVersion -> Bool
LanguageVersion -> LanguageVersion -> Ordering
LanguageVersion -> LanguageVersion -> LanguageVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LanguageVersion -> LanguageVersion -> LanguageVersion
$cmin :: LanguageVersion -> LanguageVersion -> LanguageVersion
max :: LanguageVersion -> LanguageVersion -> LanguageVersion
$cmax :: LanguageVersion -> LanguageVersion -> LanguageVersion
>= :: LanguageVersion -> LanguageVersion -> Bool
$c>= :: LanguageVersion -> LanguageVersion -> Bool
> :: LanguageVersion -> LanguageVersion -> Bool
$c> :: LanguageVersion -> LanguageVersion -> Bool
<= :: LanguageVersion -> LanguageVersion -> Bool
$c<= :: LanguageVersion -> LanguageVersion -> Bool
< :: LanguageVersion -> LanguageVersion -> Bool
$c< :: LanguageVersion -> LanguageVersion -> Bool
compare :: LanguageVersion -> LanguageVersion -> Ordering
$ccompare :: LanguageVersion -> LanguageVersion -> Ordering
$cp1Ord :: Eq LanguageVersion
Ord, Int -> LanguageVersion -> ShowS
[LanguageVersion] -> ShowS
LanguageVersion -> String
(Int -> LanguageVersion -> ShowS)
-> (LanguageVersion -> String)
-> ([LanguageVersion] -> ShowS)
-> Show LanguageVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LanguageVersion] -> ShowS
$cshowList :: [LanguageVersion] -> ShowS
show :: LanguageVersion -> String
$cshow :: LanguageVersion -> String
showsPrec :: Int -> LanguageVersion -> ShowS
$cshowsPrec :: Int -> LanguageVersion -> ShowS
Show)
data Options = Options{
Options -> Bool
foldConstants :: Bool,
Options -> Bool
checkTypes :: Bool,
Options -> LanguageVersion
version :: LanguageVersion}
moduleGrammar :: LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
moduleGrammar LanguageVersion
Oberon1 = Grammar (OberonGrammar Language NodeWrap) Parser Text
Grammar.oberonGrammar
moduleGrammar LanguageVersion
Oberon2 = Grammar (OberonGrammar Language NodeWrap) Parser Text
Grammar.oberon2Grammar
definitionGrammar :: LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
definitionGrammar LanguageVersion
Oberon1 = Grammar (OberonGrammar Language NodeWrap) Parser Text
Grammar.oberonDefinitionGrammar
definitionGrammar LanguageVersion
Oberon2 = Grammar (OberonGrammar Language NodeWrap) Parser Text
Grammar.oberon2DefinitionGrammar
parseModule :: LanguageVersion -> Text -> ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
parseModule :: LanguageVersion
-> Text
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
parseModule LanguageVersion
version Text
src =
Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Text
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall (p :: * -> *) (q :: * -> *)
(g :: (* -> *) -> (* -> *) -> *).
(p ~ NodeWrap, q ~ NodeWrap, Functor (Map p q) g) =>
Text -> p (g p p) -> q (g q q)
Resolver.resolvePositions Text
src (NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> (([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall a b. (a, b) -> b
snd
(([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall l (f :: * -> *) (p :: * -> *).
OberonGrammar l f p -> p (f (Module l l f f))
Grammar.module_prod (OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ Grammar (OberonGrammar Language NodeWrap) Parser Text
-> Text
-> OberonGrammar
Language
NodeWrap
(ResultFunctor (Parser (OberonGrammar 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 (LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
moduleGrammar LanguageVersion
version) Text
src))
parseDefinitionModule :: LanguageVersion -> Text
-> ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
parseDefinitionModule :: LanguageVersion
-> Text
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
parseDefinitionModule LanguageVersion
version Text
src =
Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Text
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall (p :: * -> *) (q :: * -> *)
(g :: (* -> *) -> (* -> *) -> *).
(p ~ NodeWrap, q ~ NodeWrap, Functor (Map p q) g) =>
Text -> p (g p p) -> q (g q q)
Resolver.resolvePositions Text
src (NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> (([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall a b. (a, b) -> b
snd
(([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall l (f :: * -> *) (p :: * -> *).
OberonGrammar l f p -> p (f (Module l l f f))
Grammar.module_prod (OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ Grammar (OberonGrammar Language NodeWrap) Parser Text
-> Text
-> OberonGrammar
Language
NodeWrap
(ResultFunctor (Parser (OberonGrammar 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 (LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
definitionGrammar LanguageVersion
version) Text
src))
parseNamedModule :: LanguageVersion -> FilePath -> Text
-> IO (ParseResults Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
parseNamedModule :: LanguageVersion
-> String
-> Text
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
parseNamedModule LanguageVersion
version String
path Text
name =
do let basePath :: String
basePath = String -> ShowS
combine String
path (Text -> String
unpack Text
name)
Bool
isDefn <- String -> IO Bool
doesFileExist (String -> ShowS
addExtension String
basePath String
"Def")
let grammar :: Grammar (OberonGrammar Language NodeWrap) Parser Text
grammar = (if Bool
isDefn then LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
definitionGrammar else LanguageVersion
-> Grammar (OberonGrammar Language NodeWrap) Parser Text
moduleGrammar) LanguageVersion
version
Text
src <- String -> IO Text
readFile (String -> ShowS
addExtension String
basePath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
isDefn then String
"Def" else String
"Mod")
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
-> Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
forall a b. (a -> b) -> a -> b
$ Text
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall (p :: * -> *) (q :: * -> *)
(g :: (* -> *) -> (* -> *) -> *).
(p ~ NodeWrap, q ~ NodeWrap, Functor (Map p q) g) =>
Text -> p (g p p) -> q (g q q)
Resolver.resolvePositions Text
src (NodeWrap (Module Language Language NodeWrap NodeWrap)
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> (([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> ([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
forall a b. (a, b) -> b
snd
(([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap))
-> NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]],
NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Either (ParseFailure Text))
[]
([[Lexeme]], NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall l (f :: * -> *) (p :: * -> *).
OberonGrammar l f p -> p (f (Module l l f f))
Grammar.module_prod (OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> OberonGrammar
Language
NodeWrap
(Compose
(Compose (Either (ParseFailure Text)) []) ((,) [[Lexeme]]))
-> Compose
(Compose (Either (ParseFailure Text)) [])
((,) [[Lexeme]])
(NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (a -> b) -> a -> b
$ Grammar (OberonGrammar Language NodeWrap) Parser Text
-> Text
-> OberonGrammar
Language
NodeWrap
(ResultFunctor (Parser (OberonGrammar 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 Grammar (OberonGrammar Language NodeWrap) Parser Text
grammar Text
src))
parseImportsOf :: LanguageVersion -> FilePath -> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO (Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
parseImportsOf :: LanguageVersion
-> String
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
parseImportsOf LanguageVersion
version String
path Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
modules =
case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
modules) [Text]
moduleImports
of [] -> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
modules
[Text]
newImports -> (((Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
modules Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a. Semigroup a => a -> a -> a
<>) (Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Map
Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> ([(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> Map
Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> [(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, NodeWrap (Module Language Language NodeWrap NodeWrap))]
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, NodeWrap (Module Language Language NodeWrap NodeWrap))]
-> Map
Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> ([(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> [(Text, NodeWrap (Module Language Language NodeWrap NodeWrap))])
-> [(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
-> (Text, NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> [(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> [(Text, NodeWrap (Module Language Language NodeWrap NodeWrap))]
forall a b. (a -> b) -> [a] -> [b]
map (Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
-> (Text, NodeWrap (Module Language Language NodeWrap NodeWrap))
forall a b. (Text, Either a [b]) -> (Text, b)
assertSuccess) ([(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> Map
Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> IO
[(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(((Text, Text)
-> IO
(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> [(Text, Text)]
-> IO
[(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Text, Text)
-> IO
(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> [(Text, Text)]
-> IO
[(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])])
-> ((Text
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> (Text, Text)
-> IO
(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> (Text
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> [(Text, Text)]
-> IO
[(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]))
-> (Text, Text)
-> IO
(Text,
ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (LanguageVersion
-> String
-> Text
-> IO
(ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)])
parseNamedModule LanguageVersion
version String
path) [(Text
p, Text
p) | Text
p <- [Text]
newImports])
IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
-> (Map
Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LanguageVersion
-> String
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
parseImportsOf LanguageVersion
version String
path
where moduleImports :: [Text]
moduleImports = (Module Language Language NodeWrap NodeWrap -> [Text])
-> Compose
(Map Text) NodeWrap (Module Language Language NodeWrap NodeWrap)
-> [Text]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Module Language Language NodeWrap NodeWrap -> [Text]
forall λ l (f' :: * -> *) (f :: * -> *). Module λ l f' f -> [Text]
importsOf (Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Compose
(Map Text) NodeWrap (Module Language Language NodeWrap NodeWrap)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
modules)
importsOf :: Module λ l f' f -> [Text]
importsOf (Module Text
_ [Import l]
imports f (Block l l f' f')
_) = Import l -> Text
forall a b. (a, b) -> b
snd (Import l -> Text) -> [Import l] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports
assertSuccess :: (Text, Either a [b]) -> (Text, b)
assertSuccess (Text
m, Left a
err) = String -> (Text, b)
forall a. HasCallStack => String -> a
error (String
"Parse error in module " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
m)
assertSuccess (Text
m, Right [b
p]) = (Text
m, b
p)
assertSuccess (Text
m, Right [b]
_) = String -> (Text, b)
forall a. HasCallStack => String -> a
error (String
"Ambiguous parses of module " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
m)
parseAndResolveModule :: Options -> FilePath -> Text
-> IO (Validation (Either (NonEmpty (Resolver.Error Language))
(NonEmpty (TypeChecker.Error Language)))
(Placed (Module Language Language Placed Placed)))
parseAndResolveModule :: Options
-> String
-> Text
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
parseAndResolveModule Options{Bool
LanguageVersion
version :: LanguageVersion
checkTypes :: Bool
foldConstants :: Bool
version :: Options -> LanguageVersion
checkTypes :: Options -> Bool
foldConstants :: Options -> Bool
..} String
path Text
source =
case LanguageVersion
-> Text
-> ParseResults
Text [NodeWrap (Module Language Language NodeWrap NodeWrap)]
parseModule LanguageVersion
version Text
source
of Left ParseFailure Text
err -> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall e a. e -> Validation e a
Failure (Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall a b. (a -> b) -> a -> b
$ NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
forall a b. a -> Either a b
Left (NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
-> NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
forall a b. (a -> b) -> a -> b
$ Text -> Error Language
forall l. Text -> Error l
Resolver.UnparseableModule (Text -> ParseFailure Text -> Int -> Text
forall s.
(Ord s, TextualMonoid s) =>
s -> ParseFailure s -> Int -> s
failureDescription Text
source ParseFailure Text
err Int
4) Error Language -> [Error Language] -> NonEmpty (Error Language)
forall a. a -> [a] -> NonEmpty a
:| [])
Right [rootModule :: NodeWrap (Module Language Language NodeWrap NodeWrap)
rootModule@(Compose ((Int, Int)
pos, Compose (Ambiguous ((ParsedLexemes
_, Module Text
moduleName [Import l]
imports NodeWrap (Block Language Language NodeWrap NodeWrap)
_) :| []))))] ->
do Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
importedModules <- LanguageVersion
-> String
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> IO
(Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap)))
parseImportsOf LanguageVersion
version String
path (Text
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
forall k a. k -> a -> Map k a
Map.singleton Text
moduleName NodeWrap (Module Language Language NodeWrap NodeWrap)
rootModule)
let resolvedImportMap :: Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
resolvedImportMap = Scope Language
-> Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
-> NodeWrap (Module Language Language NodeWrap NodeWrap)
-> Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
forall l.
(BindableDeclaration l, CoFormalParameters l,
Traversable (Resolution l) (Block l l),
Traversable (Resolution l) (Declaration l l),
Traversable (Resolution l) (Type l l),
Traversable (Resolution l) (FormalParameters l l),
Traversable (Resolution l) (ConstExpression l l),
Traversable (Resolution l) (StatementSequence l l),
Traversable (Resolution l) (Declaration l l),
Traversable (Resolution l) (Declaration l l),
Traversable (Resolution l) (StatementSequence l l),
Traversable (Resolution l) (Type l l),
Traversable (Resolution l) (FormalParameters l l),
Traversable (Resolution l) (ConstExpression l l),
At (Resolution l) (Block l l NodeWrap NodeWrap)) =>
Scope l
-> Map
Text
(Validation
(NonEmpty (Error l)) (Placed (Module l l Placed Placed)))
-> NodeWrap (Module l l NodeWrap NodeWrap)
-> Validation
(NonEmpty (Error l)) (Placed (Module l l Placed Placed))
Resolver.resolveModule Scope Language
predefinedScope Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
resolvedImportMap (NodeWrap (Module Language Language NodeWrap NodeWrap)
-> Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
-> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
-> Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (NodeWrap (Module Language Language NodeWrap NodeWrap))
importedModules
predefinedScope :: Scope Language
predefinedScope = case LanguageVersion
version
of LanguageVersion
Oberon1 -> Scope Language
forall l. Oberon l => Predefined l
Resolver.predefined
LanguageVersion
Oberon2 -> Scope Language
forall l. Oberon l => Predefined l
Resolver.predefined2
successful :: Validation e a -> Maybe a
successful (Success a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
successful Validation e a
_ = Maybe a
forall a. Maybe a
Nothing
addLeft :: Validation a a -> Validation (Either a b) a
addLeft (Failure a
resolutionErrors) = Either a b -> Validation (Either a b) a
forall e a. e -> Validation e a
Failure (a -> Either a b
forall a b. a -> Either a b
Left a
resolutionErrors)
addLeft (Success a
result) = a -> Validation (Either a b) a
forall e a. a -> Validation e a
Success a
result
constantFolded :: Map Text (Placed (Module Language Language Placed Placed))
constantFolded = Placed (Module Language Language Placed Placed)
-> Placed (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 (Placed (Module Language Language Placed Placed)
-> Placed (Module Language Language Placed Placed))
-> Map Text (Placed (Module Language Language Placed Placed))
-> Map Text (Placed (Module Language Language Placed Placed))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Environment Language
-> Map Text (Placed (Module Language Language Placed Placed))
-> Map Text (Placed (Module Language Language Placed Placed))
forall l.
(Oberon l, Nameable l, Ord (QualIdent l), Show (QualIdent l),
Atts (Inherited (Auto ConstantFold)) (Block l l Sem Sem) ~ InhCF l,
Atts (Synthesized (Auto ConstantFold)) (Block l l Sem Sem)
~ SynCFMod' l (Block l l),
Functor (Auto ConstantFold) (Block l l),
Functor (Auto ConstantFold) (Block l l)) =>
Environment l
-> Map Text (Placed (Module l l Placed Placed))
-> Map Text (Placed (Module l l Placed Placed))
ConstantFolder.foldConstants
(case LanguageVersion
version
of LanguageVersion
Oberon1 -> Environment Language
forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
ConstantFolder.predefined
LanguageVersion
Oberon2 -> Environment Language
forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
ConstantFolder.predefined2)
((Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
-> Maybe (Placed (Module Language Language Placed Placed)))
-> Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
-> Map Text (Placed (Module Language Language Placed Placed))
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
-> Maybe (Placed (Module Language Language Placed Placed))
forall e a. Validation e a -> Maybe a
successful Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
resolvedImportMap)
typeErrors :: [Error Language]
typeErrors = Environment Language
-> Map Text (Placed (Module Language Language Placed Placed))
-> [Error Language]
forall l.
(Oberon l, Nameable l, Ord (QualIdent l), Show (QualIdent l),
Atts (Inherited (Auto TypeCheck)) (Block l l Sem Sem) ~ InhTC l,
Atts (Synthesized (Auto TypeCheck)) (Block l l Sem Sem)
~ SynTCMod l,
Functor (Auto TypeCheck) (Block l l)) =>
Environment l
-> Map Text (Placed (Module l l Placed Placed)) -> [Error l]
TypeChecker.checkModules
(case LanguageVersion
version
of LanguageVersion
Oberon1 -> Environment Language
forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
TypeChecker.predefined
LanguageVersion
Oberon2 -> Environment Language
forall l. (Wirthy l, Ord (QualIdent l)) => Environment l
TypeChecker.predefined2)
Map Text (Placed (Module Language Language Placed Placed))
constantFolded
Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
checkTypes Bool -> Bool -> Bool
&& Bool -> Bool
not ([Error Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error Language]
typeErrors)
then Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall e a. e -> Validation e a
Failure (NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
forall a b. b -> Either a b
Right ([Error Language] -> NonEmpty (Error Language)
forall a. [a] -> NonEmpty a
NonEmpty.fromList [Error Language]
typeErrors))
else Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
-> (Placed (Module Language Language Placed Placed)
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
-> Maybe (Placed (Module Language Language Placed Placed))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall a a b. Validation a a -> Validation (Either a b) a
addLeft (Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
-> Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall a b. (a -> b) -> a -> b
$ Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
resolvedImportMap Map
Text
(Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed)))
-> Text
-> Validation
(NonEmpty (Error Language))
(Placed (Module Language Language Placed Placed))
forall k a. Ord k => Map k a -> k -> a
Map.! Text
moduleName) Placed (Module Language Language Placed Placed)
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall e a. a -> Validation e a
Success
(Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
foldConstants Maybe ()
-> Maybe (Placed (Module Language Language Placed Placed))
-> Maybe (Placed (Module Language Language Placed Placed))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> Map Text (Placed (Module Language Language Placed Placed))
-> Maybe (Placed (Module Language Language Placed Placed))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
moduleName Map Text (Placed (Module Language Language Placed Placed))
constantFolded))
Right [NodeWrap (Module Language Language NodeWrap NodeWrap)]
_ -> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall e a. e -> Validation e a
Failure (Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
-> Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))
forall a b. (a -> b) -> a -> b
$ NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
forall a b. a -> Either a b
Left (NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
-> NonEmpty (Error Language)
-> Either (NonEmpty (Error Language)) (NonEmpty (Error Language))
forall a b. (a -> b) -> a -> b
$ Error Language
forall l. Error l
Resolver.AmbiguousParses Error Language -> [Error Language] -> NonEmpty (Error Language)
forall a. a -> [a] -> NonEmpty a
:| [])
parseAndResolveModuleFile :: Options -> FilePath
-> IO (Validation (Either (NonEmpty (Resolver.Error Language)) (NonEmpty (TypeChecker.Error Language)))
(Placed (Module Language Language Placed Placed)))
parseAndResolveModuleFile :: Options
-> String
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
parseAndResolveModuleFile Options
options String
path =
String -> IO Text
readFile String
path IO Text
-> (Text
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed))))
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Options
-> String
-> Text
-> IO
(Validation
(Either (NonEmpty (Error Language)) (NonEmpty (Error Language)))
(Placed (Module Language Language Placed Placed)))
parseAndResolveModule Options
options (ShowS
takeDirectory String
path)