language-oberon-0.2.1: src/Language/Oberon.hs

-- | Every function in this module takes a flag that determines whether the input is an Oberon or Oberon-2 module.

module Language.Oberon (parseModule, parseAndResolveModule, parseAndResolveModuleFile) where

import Language.Oberon.AST (Module(..))
import qualified Language.Oberon.Grammar as Grammar
import qualified Language.Oberon.Resolver as Resolver
import qualified Language.Oberon.TypeChecker as TypeChecker

import Control.Monad (when)
import Data.Either.Validation (Validation(..))
import Data.Functor.Identity (Identity)
import Data.Functor.Compose (getCompose)
import Data.List.NonEmpty (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, Grammar, ParseResults, parseComplete)
import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive
import System.Directory (doesFileExist)
import System.FilePath (FilePath, addExtension, combine, takeDirectory)

import Prelude hiding (readFile)

-- | Parse the given text of a single module, without resolving the syntactic ambiguities.
parseModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous]
parseModule oberon2 = getCompose . Grammar.module_prod
                      . parseComplete (if oberon2 then Grammar.oberon2Grammar else Grammar.oberonGrammar)

-- | Parse the given text of a single /definition/ module, without resolving the syntactic ambiguities.
parseDefinitionModule :: Bool -> Text -> ParseResults [Module Ambiguous Ambiguous]
parseDefinitionModule oberon2 = getCompose . Grammar.module_prod
                                . parseComplete (if oberon2 then Grammar.oberon2DefinitionGrammar
                                                 else Grammar.oberonDefinitionGrammar)

parseNamedModule :: Bool -> FilePath -> Text -> IO (ParseResults [Module Ambiguous Ambiguous])
parseNamedModule oberon2 path name =
   do let basePath = combine path (unpack name)
      isDefn <- doesFileExist (addExtension basePath "Def")
      let grammar = if oberon2
                    then if isDefn then Grammar.oberon2DefinitionGrammar else Grammar.oberon2Grammar
                    else if isDefn then Grammar.oberonDefinitionGrammar else Grammar.oberonGrammar
      getCompose . Grammar.module_prod . parseComplete grammar
         <$> readFile (addExtension basePath $ if isDefn then "Def" else "Mod")

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

-- | Given a directory path for module imports, parse the given module text and all the module files it imports, then
-- use all the information to resolve the syntactic ambiguities.
parseAndResolveModule :: Bool -> Bool -> FilePath -> Text
                      -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity))
parseAndResolveModule checkTypes oberon2 path source =
   case parseModule oberon2 source
   of Left err -> return (Failure $ Resolver.UnparseableModule err :| [])
      Right [rootModule@(Module moduleName imports _ _ _)] ->
         do importedModules <- parseImportsOf oberon2 path (Map.singleton moduleName rootModule)
            let resolvedImportMap = Resolver.resolveModule predefinedScope resolvedImportMap <$> importedModules
                predefinedScope = if oberon2 then Resolver.predefined2 else Resolver.predefined
                successful (Success a) = Just a
                successful _ = Nothing
                typeErrors = TypeChecker.checkModules
                                (if oberon2 then TypeChecker.predefined2 else TypeChecker.predefined)
                                (Map.mapMaybe successful resolvedImportMap)
            when (checkTypes && not (null typeErrors)) (error $ show typeErrors)
            return $ resolvedImportMap Map.! moduleName
      Right _ -> return (Failure $ Resolver.AmbiguousParses :| [])

-- | Parse the module file at the given path, assuming all its imports are in the same directory.
parseAndResolveModuleFile :: Bool -> Bool -> FilePath
                          -> IO (Validation (NonEmpty Resolver.Error) (Module Identity Identity))
parseAndResolveModuleFile checkTypes oberon2 path =
  readFile path >>= parseAndResolveModule checkTypes oberon2 (takeDirectory path)