{- |
    Module      :  $Header$
    Description :  Compilation of a single module
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2007        Sebastian Fischer
                       2011 - 2015 Björn Peemöller
                       2016        Jan Tikovsky
                       2016 - 2017 Finn Teegen
                       2018        Kai-Oliver Prott
    License     :  BSD-3-clause

    Maintainer  :  fte@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module controls the compilation of modules.
-}

module Modules
  ( compileModule, loadAndCheckModule, loadModule, checkModule
  , parseModule, checkModuleHeader
  ) where

import qualified Control.Exception as C   (catch, IOException)
import           Control.Monad            (liftM, unless, when)
import           Data.Char                (toUpper)
import qualified Data.Map          as Map (elems, lookup)
import           Data.Maybe               (fromMaybe)
import           System.Directory         (getTemporaryDirectory, removeFile)
import           System.Exit              (ExitCode (..))
import           System.FilePath          (normalise)
import           System.IO
   (IOMode (ReadMode), Handle, hClose, hGetContents, hPutStr, openFile
  , openTempFile)
import           System.Process           (system)

import Curry.Base.Ident
import Curry.Base.Monad
import Curry.Base.SpanInfo
import Curry.Base.Pretty
import Curry.Base.Span
import Curry.FlatCurry.InterfaceEquivalence (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax.InterfaceEquivalence
import Curry.Syntax.Utils (shortenModuleAST)

import Base.Messages
import Base.Types

import Env.Interface

-- source representations
import qualified Curry.AbstractCurry as AC
import qualified Curry.FlatCurry     as FC
import qualified Curry.Syntax        as CS
import qualified IL

import Checks
import CompilerEnv
import CompilerOpts
import CondCompile (condCompile)
import Exports
import Generators
import Html.CurryHtml (source2html)
import Imports
import Interfaces (loadInterfaces)
import TokenStream (showTokenStream, showCommentTokenStream)
import Transformations

-- The function 'compileModule' is the main entry-point of this
-- module for compiling a Curry source module. Depending on the command
-- line options, it will emit either FlatCurry code or AbstractCurry code
-- (typed, untyped or with type signatures) for the module.
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
-- language. If necessary, this phase will also update the module's
-- interface file. The resulting code then is written out
-- to the corresponding file.
-- The untyped  AbstractCurry representation is written
-- out directly after parsing and simple checking the source file.
-- The typed AbstractCurry code is written out after checking the module.
--
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
compileModule :: Options -> ModuleIdent -> FilePath -> CYIO ()
compileModule :: Options -> ModuleIdent -> FilePath -> CYIO ()
compileModule opts :: Options
opts m :: ModuleIdent
m fn :: FilePath
fn = do
  CompEnv (Module PredType)
mdl <- Options
-> ModuleIdent -> FilePath -> CYIO (CompEnv (Module PredType))
loadAndCheckModule Options
opts ModuleIdent
m FilePath
fn
  Options -> CompilerEnv -> CYIO ()
writeTokens   Options
opts (CompEnv (Module PredType) -> CompilerEnv
forall a b. (a, b) -> a
fst CompEnv (Module PredType)
mdl)
  Options -> CompilerEnv -> CYIO ()
writeComments Options
opts (CompEnv (Module PredType) -> CompilerEnv
forall a b. (a, b) -> a
fst CompEnv (Module PredType)
mdl)
  Options -> CompEnv (Module PredType) -> CYIO ()
forall a. Show a => Options -> CompEnv (Module a) -> CYIO ()
writeParsed   Options
opts CompEnv (Module PredType)
mdl
  let qmdl :: CompEnv (Module PredType)
qmdl = CompEnv (Module PredType) -> CompEnv (Module PredType)
forall a. CompEnv (Module a) -> CompEnv (Module a)
qual CompEnv (Module PredType)
mdl
  Options -> CompEnv (Module PredType) -> CYIO ()
forall a. Options -> CompEnv (Module a) -> CYIO ()
writeHtml     Options
opts CompEnv (Module PredType)
qmdl
  Options -> CompEnv (Module ()) -> CYIO ()
writeAST      Options
opts (CompEnv (Module PredType) -> CompilerEnv
forall a b. (a, b) -> a
fst  CompEnv (Module PredType)
mdl, (PredType -> ()) -> Module PredType -> Module ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> PredType -> ()
forall a b. a -> b -> a
const ()) (CompEnv (Module PredType) -> Module PredType
forall a b. (a, b) -> b
snd  CompEnv (Module PredType)
mdl))
  Options -> CompEnv (Module ()) -> CYIO ()
writeShortAST Options
opts (CompEnv (Module PredType) -> CompilerEnv
forall a b. (a, b) -> a
fst CompEnv (Module PredType)
qmdl, (PredType -> ()) -> Module PredType -> Module ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> PredType -> ()
forall a b. a -> b -> a
const ()) (CompEnv (Module PredType) -> Module PredType
forall a b. (a, b) -> b
snd CompEnv (Module PredType)
qmdl))
  CompEnv (Module PredType)
mdl' <- Options
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a.
Monad m =>
Options -> CompEnv (Module a) -> m (CompEnv (Module a))
expandExports Options
opts CompEnv (Module PredType)
mdl
  CompEnv (Module PredType)
qmdl' <- Options
-> (Module PredType -> FilePath)
-> (Module PredType -> Doc)
-> DumpLevel
-> CompEnv (Module PredType)
-> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts Module PredType -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule Module PredType -> Doc
forall a. Module a -> Doc
CS.ppModule DumpLevel
DumpQualified (CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType)))
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module PredType) -> CompEnv (Module PredType)
forall a. CompEnv (Module a) -> CompEnv (Module a)
qual CompEnv (Module PredType)
mdl'
  Options -> CompEnv (Module PredType) -> CYIO ()
writeAbstractCurry Options
opts CompEnv (Module PredType)
qmdl'
  -- generate interface file
  let intf :: Interface
intf = (CompilerEnv -> Module PredType -> Interface)
-> CompEnv (Module PredType) -> Interface
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CompilerEnv -> Module PredType -> Interface
forall a. CompilerEnv -> Module a -> Interface
exportInterface CompEnv (Module PredType)
qmdl'
  Options -> CompilerEnv -> Interface -> CYIO ()
writeInterface Options
opts (CompEnv (Module PredType) -> CompilerEnv
forall a b. (a, b) -> a
fst CompEnv (Module PredType)
mdl') Interface
intf
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withFlat (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ do
    ((env :: CompilerEnv
env, il :: Module
il), mdl'' :: CompEnv (Module Type)
mdl'') <- Options
-> CompEnv (Module PredType)
-> CYIO (CompEnv Module, CompEnv (Module Type))
transModule Options
opts CompEnv (Module PredType)
qmdl'
    Options -> CompilerEnv -> Module Type -> Module -> CYIO ()
writeFlat Options
opts CompilerEnv
env (CompEnv (Module Type) -> Module Type
forall a b. (a, b) -> b
snd CompEnv (Module Type)
mdl'') Module
il
  where
  withFlat :: Bool
withFlat = (TargetType -> Bool) -> [TargetType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts) [TargetType
TypedFlatCurry, TargetType
FlatCurry]

loadAndCheckModule :: Options -> ModuleIdent -> FilePath
                   -> CYIO (CompEnv (CS.Module PredType))
loadAndCheckModule :: Options
-> ModuleIdent -> FilePath -> CYIO (CompEnv (Module PredType))
loadAndCheckModule opts :: Options
opts m :: ModuleIdent
m fn :: FilePath
fn = do
  CompEnv (Module PredType)
ce <- Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (Module ()))
loadModule Options
opts ModuleIdent
m FilePath
fn CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module PredType)))
-> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Options -> CompEnv (Module ()) -> CYIO (CompEnv (Module PredType))
checkModule Options
opts
  [Message] -> CYIO ()
forall (m :: * -> *). Monad m => [Message] -> CYT m ()
warnMessages ([Message] -> CYIO ()) -> [Message] -> CYIO ()
forall a b. (a -> b) -> a -> b
$ (CompilerEnv -> Module PredType -> [Message])
-> CompEnv (Module PredType) -> [Message]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Options -> CompilerEnv -> Module PredType -> [Message]
forall a. Options -> CompilerEnv -> Module a -> [Message]
warnCheck Options
opts) CompEnv (Module PredType)
ce
  CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a. Monad m => a -> m a
return CompEnv (Module PredType)
ce

-- ---------------------------------------------------------------------------
-- Loading a module
-- ---------------------------------------------------------------------------

loadModule :: Options -> ModuleIdent -> FilePath
           -> CYIO (CompEnv (CS.Module ()))
loadModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (Module ()))
loadModule opts :: Options
opts m :: ModuleIdent
m fn :: FilePath
fn = do
  -- parse and check module header
  (toks :: [(Span, Token)]
toks, mdl :: Module ()
mdl) <- Options
-> ModuleIdent -> FilePath -> CYIO ([(Span, Token)], Module ())
parseModule Options
opts ModuleIdent
m FilePath
fn
  -- load the imported interfaces into an InterfaceEnv
  let paths :: [FilePath]
paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> FilePath -> FilePath
addCurrySubdir (Options -> Bool
optUseSubdir Options
opts))
                  ("." FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Options -> [FilePath]
optImportPaths Options
opts)
  let withPrel :: Module ()
withPrel = Options -> Module () -> Module ()
importPrelude Options
opts Module ()
mdl
  InterfaceEnv
iEnv   <- [FilePath] -> Module () -> CYIO InterfaceEnv
forall a. [FilePath] -> Module a -> CYIO InterfaceEnv
loadInterfaces [FilePath]
paths Module ()
withPrel
  Options -> InterfaceEnv -> CYIO ()
forall (m :: * -> *).
Monad m =>
Options -> InterfaceEnv -> CYT m ()
checkInterfaces Options
opts InterfaceEnv
iEnv
  [ImportDecl]
is     <- InterfaceEnv -> Module () -> CYT IO [ImportDecl]
forall (m :: * -> *) a.
Monad m =>
InterfaceEnv -> Module a -> CYT m [ImportDecl]
importSyntaxCheck InterfaceEnv
iEnv Module ()
withPrel
  -- add information of imported modules
  CompilerEnv
cEnv   <- Module () -> InterfaceEnv -> [ImportDecl] -> CYT IO CompilerEnv
forall (m :: * -> *) a.
Monad m =>
Module a -> InterfaceEnv -> [ImportDecl] -> CYT m CompilerEnv
importModules Module ()
withPrel InterfaceEnv
iEnv [ImportDecl]
is
  CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (CompilerEnv
cEnv { filePath :: FilePath
filePath = FilePath
fn, tokens :: [(Span, Token)]
tokens = [(Span, Token)]
toks }, Module ()
mdl)

parseModule :: Options -> ModuleIdent -> FilePath
            -> CYIO ([(Span, CS.Token)], CS.Module ())
parseModule :: Options
-> ModuleIdent -> FilePath -> CYIO ([(Span, Token)], Module ())
parseModule opts :: Options
opts m :: ModuleIdent
m fn :: FilePath
fn = do
  Maybe FilePath
mbSrc <- IO (Maybe FilePath)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath)
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe FilePath))
-> IO (Maybe FilePath)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
readModule FilePath
fn
  case Maybe FilePath
mbSrc of
    Nothing  -> [Message] -> CYIO ([(Span, Token)], Module ())
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ "Missing file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fn]
    Just src :: FilePath
src -> do
      FilePath
ul      <- CYM FilePath -> CYT IO FilePath
forall (m :: * -> *) a. Monad m => CYM a -> CYT m a
liftCYM (CYM FilePath -> CYT IO FilePath)
-> CYM FilePath -> CYT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CYM FilePath
CS.unlit FilePath
fn FilePath
src
      FilePath
prepd   <- PrepOpts -> FilePath -> FilePath -> CYT IO FilePath
preprocess (Options -> PrepOpts
optPrepOpts Options
opts) FilePath
fn FilePath
ul
      FilePath
condC   <- CppOpts -> FilePath -> FilePath -> CYT IO FilePath
condCompile (Options -> CppOpts
optCppOpts Options
opts) FilePath
fn FilePath
prepd
      DebugOpts -> Dump -> CYIO ()
forall (m :: * -> *). MonadIO m => DebugOpts -> Dump -> m ()
doDump ((Options -> DebugOpts
optDebugOpts Options
opts) { dbDumpEnv :: Bool
dbDumpEnv = Bool
False })
             (DumpLevel
DumpCondCompiled, CompilerEnv
forall a. HasCallStack => a
undefined, FilePath
condC)
      -- We ignore the warnings issued by the lexer because
      -- they will be issued a second time during parsing.
      [(Span, Token)]
spanToks <- CYM [(Span, Token)] -> CYT IO [(Span, Token)]
forall (m :: * -> *) a. Monad m => CYM a -> CYT m a
liftCYM (CYM [(Span, Token)] -> CYT IO [(Span, Token)])
-> CYM [(Span, Token)] -> CYT IO [(Span, Token)]
forall a b. (a -> b) -> a -> b
$ CYM [(Span, Token)] -> CYM [(Span, Token)]
forall (m :: * -> *) a. Monad m => CYT m a -> CYT m a
silent (CYM [(Span, Token)] -> CYM [(Span, Token)])
-> CYM [(Span, Token)] -> CYM [(Span, Token)]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CYM [(Span, Token)]
CS.lexSource FilePath
fn FilePath
condC
      Module ()
ast      <- CYM (Module ()) -> CYT IO (Module ())
forall (m :: * -> *) a. Monad m => CYM a -> CYT m a
liftCYM (CYM (Module ()) -> CYT IO (Module ()))
-> CYM (Module ()) -> CYT IO (Module ())
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CYM (Module ())
CS.parseModule FilePath
fn FilePath
condC
      Module ()
checked  <- ModuleIdent -> FilePath -> Module () -> CYT IO (Module ())
forall (m :: * -> *).
Monad m =>
ModuleIdent -> FilePath -> Module () -> CYT m (Module ())
checkModuleHeader ModuleIdent
m FilePath
fn Module ()
ast
      ([(Span, Token)], Module ()) -> CYIO ([(Span, Token)], Module ())
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Span, Token)]
spanToks, Module ()
checked)

preprocess :: PrepOpts -> FilePath -> String -> CYIO String
preprocess :: PrepOpts -> FilePath -> FilePath -> CYT IO FilePath
preprocess opts :: PrepOpts
opts fn :: FilePath
fn src :: FilePath
src
  | Bool -> Bool
not (PrepOpts -> Bool
ppPreprocess PrepOpts
opts) = FilePath -> CYT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
src
  | Bool
otherwise               = do
    Either [Message] FilePath
res <- IO (Either [Message] FilePath)
-> WriterT
     [Message] (ExceptT [Message] IO) (Either [Message] FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Message] FilePath)
 -> WriterT
      [Message] (ExceptT [Message] IO) (Either [Message] FilePath))
-> IO (Either [Message] FilePath)
-> WriterT
     [Message] (ExceptT [Message] IO) (Either [Message] FilePath)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Handle -> IO (Either [Message] FilePath))
-> IO (Either [Message] FilePath)
forall a. (FilePath -> Handle -> IO a) -> IO a
withTempFile ((FilePath -> Handle -> IO (Either [Message] FilePath))
 -> IO (Either [Message] FilePath))
-> (FilePath -> Handle -> IO (Either [Message] FilePath))
-> IO (Either [Message] FilePath)
forall a b. (a -> b) -> a -> b
$ \ inFn :: FilePath
inFn inHdl :: Handle
inHdl -> do
      Handle -> FilePath -> IO ()
hPutStr Handle
inHdl FilePath
src
      Handle -> IO ()
hClose Handle
inHdl
      (FilePath -> Handle -> IO (Either [Message] FilePath))
-> IO (Either [Message] FilePath)
forall a. (FilePath -> Handle -> IO a) -> IO a
withTempFile ((FilePath -> Handle -> IO (Either [Message] FilePath))
 -> IO (Either [Message] FilePath))
-> (FilePath -> Handle -> IO (Either [Message] FilePath))
-> IO (Either [Message] FilePath)
forall a b. (a -> b) -> a -> b
$ \ outFn :: FilePath
outFn outHdl :: Handle
outHdl -> do
        Handle -> IO ()
hClose Handle
outHdl
        ExitCode
ec <- FilePath -> IO ExitCode
system (FilePath -> IO ExitCode) -> FilePath -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
          [PrepOpts -> FilePath
ppCmd PrepOpts
opts, FilePath -> FilePath
normalise FilePath
fn, FilePath
inFn, FilePath
outFn] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ PrepOpts -> [FilePath]
ppOpts PrepOpts
opts
        case ExitCode
ec of
          ExitFailure x :: Int
x -> Either [Message] FilePath -> IO (Either [Message] FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Message] FilePath -> IO (Either [Message] FilePath))
-> Either [Message] FilePath -> IO (Either [Message] FilePath)
forall a b. (a -> b) -> a -> b
$ [Message] -> Either [Message] FilePath
forall a b. a -> Either a b
Left [Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$
              "Preprocessor exited with exit code " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x]
          ExitSuccess   -> FilePath -> Either [Message] FilePath
forall a b. b -> Either a b
Right (FilePath -> Either [Message] FilePath)
-> IO FilePath -> IO (Either [Message] FilePath)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` FilePath -> IO FilePath
readFile FilePath
outFn
    ([Message] -> CYT IO FilePath)
-> (FilePath -> CYT IO FilePath)
-> Either [Message] FilePath
-> CYT IO FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Message] -> CYT IO FilePath
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages FilePath -> CYT IO FilePath
forall (m :: * -> *) a. Monad m => a -> CYT m a
ok Either [Message] FilePath
res

withTempFile :: (FilePath -> Handle -> IO a) -> IO a
withTempFile :: (FilePath -> Handle -> IO a) -> IO a
withTempFile act :: FilePath -> Handle -> IO a
act = do
  FilePath
tmp       <- IO FilePath
getTemporaryDirectory
  (fn :: FilePath
fn, hdl :: Handle
hdl) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmp "cymake.curry"
  a
res       <- FilePath -> Handle -> IO a
act FilePath
fn Handle
hdl
  Handle -> IO ()
hClose Handle
hdl
  FilePath -> IO ()
removeFile FilePath
fn
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

checkModuleHeader :: Monad m => ModuleIdent -> FilePath
                  -> CS.Module () -> CYT m (CS.Module ())
checkModuleHeader :: ModuleIdent -> FilePath -> Module () -> CYT m (Module ())
checkModuleHeader m :: ModuleIdent
m fn :: FilePath
fn = ModuleIdent -> Module () -> CYT m (Module ())
forall (m :: * -> *).
Monad m =>
ModuleIdent -> Module () -> CYT m (Module ())
checkModuleId ModuleIdent
m
                       (Module () -> CYT m (Module ()))
-> (Module () -> Module ()) -> Module () -> CYT m (Module ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Module () -> Module ()
forall a. FilePath -> Module a -> Module a
CS.patchModuleId FilePath
fn

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ())
checkModuleId :: ModuleIdent -> Module () -> CYT m (Module ())
checkModuleId mid :: ModuleIdent
mid m :: Module ()
m@(CS.Module _ _ mid' :: ModuleIdent
mid' _ _ _)
  | ModuleIdent
mid ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
mid' = Module () -> CYT m (Module ())
forall (m :: * -> *) a. Monad m => a -> CYT m a
ok Module ()
m
  | Bool
otherwise   = [Message] -> CYT m (Module ())
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [ModuleIdent -> Message
errModuleFileMismatch ModuleIdent
mid']

-- An implicit import of the prelude is temporariliy added to the declarations
-- of every module, except for the prelude itself, or when the import is
-- disabled by a compiler option. If no explicit import for the prelude is
-- present, the prelude is imported unqualified,
-- otherwise a qualified import is added.

importPrelude :: Options -> CS.Module () -> CS.Module ()
importPrelude :: Options -> Module () -> Module ()
importPrelude opts :: Options
opts m :: Module ()
m@(CS.Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps mid :: ModuleIdent
mid es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl ()]
ds)
    -- the Prelude itself
  | ModuleIdent
mid ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
preludeMIdent          = Module ()
m
    -- disabled by compiler option
  | Bool
noImpPrelude                  = Module ()
m
    -- already imported
  | ModuleIdent
preludeMIdent ModuleIdent -> [ModuleIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleIdent]
imported = Module ()
m
    -- let's add it!
  | Bool
otherwise                     = SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl ()]
-> Module ()
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
CS.Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
mid Maybe ExportSpec
es (ImportDecl
preludeImp ImportDecl -> [ImportDecl] -> [ImportDecl]
forall a. a -> [a] -> [a]
: [ImportDecl]
is) [Decl ()]
ds
  where
  noImpPrelude :: Bool
noImpPrelude = KnownExtension
NoImplicitPrelude KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [KnownExtension]
optExtensions Options
opts
                 Bool -> Bool -> Bool
|| Module ()
m Module () -> KnownExtension -> Bool
forall a. Module a -> KnownExtension -> Bool
`CS.hasLanguageExtension` KnownExtension
NoImplicitPrelude
  preludeImp :: ImportDecl
preludeImp   = SpanInfo
-> ModuleIdent
-> Bool
-> Maybe ModuleIdent
-> Maybe ImportSpec
-> ImportDecl
CS.ImportDecl SpanInfo
NoSpanInfo ModuleIdent
preludeMIdent
                  Bool
False   -- qualified?
                  Maybe ModuleIdent
forall a. Maybe a
Nothing -- no alias
                  Maybe ImportSpec
forall a. Maybe a
Nothing -- no selection of types, functions, etc.
  imported :: [ModuleIdent]
imported     = [ModuleIdent
imp | (CS.ImportDecl _ imp :: ModuleIdent
imp _ _ _) <- [ImportDecl]
is]

checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()
checkInterfaces :: Options -> InterfaceEnv -> CYT m ()
checkInterfaces opts :: Options
opts iEnv :: InterfaceEnv
iEnv = (Interface
 -> WriterT [Message] (ExceptT [Message] m) (CompEnv Interface))
-> [Interface] -> CYT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Interface
-> WriterT [Message] (ExceptT [Message] m) (CompEnv Interface)
forall (m :: * -> *).
Monad m =>
Interface -> CYT m (CompEnv Interface)
checkInterface (InterfaceEnv -> [Interface]
forall k a. Map k a -> [a]
Map.elems InterfaceEnv
iEnv)
  where
  checkInterface :: Interface -> CYT m (CompEnv Interface)
checkInterface intf :: Interface
intf = do
    let env :: CompilerEnv
env = Interface -> InterfaceEnv -> CompilerEnv
importInterfaces Interface
intf InterfaceEnv
iEnv
    Check m Interface
forall (m :: * -> *). Monad m => Check m Interface
interfaceCheck Options
opts (CompilerEnv
env, Interface
intf)

importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl]
importSyntaxCheck :: InterfaceEnv -> Module a -> CYT m [ImportDecl]
importSyntaxCheck iEnv :: InterfaceEnv
iEnv (CS.Module _ _ _ _ imps :: [ImportDecl]
imps _) = (ImportDecl -> WriterT [Message] (ExceptT [Message] m) ImportDecl)
-> [ImportDecl] -> CYT m [ImportDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ImportDecl -> WriterT [Message] (ExceptT [Message] m) ImportDecl
forall (m :: * -> *).
Monad m =>
ImportDecl -> WriterT [Message] (ExceptT [Message] m) ImportDecl
checkImportDecl [ImportDecl]
imps
  where
  checkImportDecl :: ImportDecl -> WriterT [Message] (ExceptT [Message] m) ImportDecl
checkImportDecl (CS.ImportDecl p :: SpanInfo
p m :: ModuleIdent
m q :: Bool
q asM :: Maybe ModuleIdent
asM is :: Maybe ImportSpec
is) = case ModuleIdent -> InterfaceEnv -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleIdent
m InterfaceEnv
iEnv of
    Just intf :: Interface
intf -> SpanInfo
-> ModuleIdent
-> Bool
-> Maybe ModuleIdent
-> Maybe ImportSpec
-> ImportDecl
CS.ImportDecl SpanInfo
p ModuleIdent
m Bool
q Maybe ModuleIdent
asM (Maybe ImportSpec -> ImportDecl)
-> WriterT [Message] (ExceptT [Message] m) (Maybe ImportSpec)
-> WriterT [Message] (ExceptT [Message] m) ImportDecl
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Interface
-> Maybe ImportSpec
-> WriterT [Message] (ExceptT [Message] m) (Maybe ImportSpec)
forall (m :: * -> *).
Monad m =>
Interface -> Maybe ImportSpec -> CYT m (Maybe ImportSpec)
importCheck Interface
intf Maybe ImportSpec
is
    Nothing   -> FilePath -> WriterT [Message] (ExceptT [Message] m) ImportDecl
forall a. FilePath -> a
internalError (FilePath -> WriterT [Message] (ExceptT [Message] m) ImportDecl)
-> FilePath -> WriterT [Message] (ExceptT [Message] m) ImportDecl
forall a b. (a -> b) -> a -> b
$ "Modules.importModules: no interface for "
                                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ModuleIdent -> FilePath
forall a. Show a => a -> FilePath
show ModuleIdent
m

-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

-- TODO: The order of the checks should be improved!
checkModule :: Options -> CompEnv (CS.Module ())
            -> CYIO (CompEnv (CS.Module PredType))
checkModule :: Options -> CompEnv (Module ()) -> CYIO (CompEnv (Module PredType))
checkModule opts :: Options
opts mdl :: CompEnv (Module ())
mdl = do
  CompEnv (Module ())
_   <- DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpParsed CompEnv (Module ())
mdl
  CompEnv (Module ())
exc <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
extensionCheck  Options
opts CompEnv (Module ())
mdl CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpExtensionChecked
  CompEnv (Module ())
tsc <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
typeSyntaxCheck Options
opts CompEnv (Module ())
exc CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpTypeSyntaxChecked
  CompEnv (Module ())
kc  <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
kindCheck       Options
opts CompEnv (Module ())
tsc CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpKindChecked
  CompEnv (Module ())
sc  <- Check IO (Module ())
forall (m :: * -> *). Monad m => Check m (Module ())
syntaxCheck     Options
opts CompEnv (Module ())
kc  CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpSyntaxChecked
  CompEnv (Module ())
pc  <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
precCheck       Options
opts CompEnv (Module ())
sc  CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpPrecChecked
  CompEnv (Module ())
dc  <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
deriveCheck     Options
opts CompEnv (Module ())
pc  CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpDeriveChecked
  CompEnv (Module ())
inc <- Check IO (Module ())
forall (m :: * -> *) a. Monad m => Check m (Module a)
instanceCheck   Options
opts CompEnv (Module ())
dc  CYIO (CompEnv (Module ()))
-> (CompEnv (Module ()) -> CYIO (CompEnv (Module ())))
-> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel -> CompEnv (Module ()) -> CYIO (CompEnv (Module ()))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpInstanceChecked
  CompEnv (Module PredType)
tc  <- Options -> CompEnv (Module ()) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a.
Monad m =>
Options -> CompEnv (Module a) -> CYT m (CompEnv (Module PredType))
typeCheck       Options
opts CompEnv (Module ())
inc CYIO (CompEnv (Module PredType))
-> (CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType)))
-> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpTypeChecked
  CompEnv (Module PredType)
ec  <- Options
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a. Monad m => Check m (Module a)
exportCheck     Options
opts CompEnv (Module PredType)
tc  CYIO (CompEnv (Module PredType))
-> (CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType)))
-> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DumpLevel
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS DumpLevel
DumpExportChecked
  CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall (m :: * -> *) a. Monad m => a -> m a
return CompEnv (Module PredType)
ec
  where
  dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a)
         -> m (CompEnv (CS.Module a))
  dumpCS :: DumpLevel -> CompEnv (Module a) -> m (CompEnv (Module a))
dumpCS = Options
-> (Module a -> FilePath)
-> (Module a -> Doc)
-> DumpLevel
-> CompEnv (Module a)
-> m (CompEnv (Module a))
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts Module a -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule Module a -> Doc
forall a. Module a -> Doc
CS.ppModule

-- ---------------------------------------------------------------------------
-- Translating a module
-- ---------------------------------------------------------------------------

transModule :: Options -> CompEnv (CS.Module PredType)
            -> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type))
transModule :: Options
-> CompEnv (Module PredType)
-> CYIO (CompEnv Module, CompEnv (Module Type))
transModule opts :: Options
opts mdl :: CompEnv (Module PredType)
mdl = do
  CompEnv (Module PredType)
derived    <- DumpLevel
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpDerived       (CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType)))
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module PredType) -> CompEnv (Module PredType)
derive         CompEnv (Module PredType)
mdl
  CompEnv (Module PredType)
desugared  <- DumpLevel
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpDesugared     (CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType)))
-> CompEnv (Module PredType) -> CYIO (CompEnv (Module PredType))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module PredType) -> CompEnv (Module PredType)
desugar        CompEnv (Module PredType)
derived
  CompEnv (Module Type)
dicts      <- DumpLevel -> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpDictionaries  (CompEnv (Module Type) -> CYIO (CompEnv (Module Type)))
-> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module PredType) -> CompEnv (Module Type)
insertDicts    CompEnv (Module PredType)
desugared
  CompEnv (Module Type)
newtypes   <- DumpLevel -> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpNewtypes      (CompEnv (Module Type) -> CYIO (CompEnv (Module Type)))
-> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module Type) -> CompEnv (Module Type)
removeNewtypes CompEnv (Module Type)
dicts
  CompEnv (Module Type)
simplified <- DumpLevel -> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpSimplified    (CompEnv (Module Type) -> CYIO (CompEnv (Module Type)))
-> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module Type) -> CompEnv (Module Type)
simplify       CompEnv (Module Type)
newtypes
  CompEnv (Module Type)
lifted     <- DumpLevel -> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a.
Show a =>
DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS DumpLevel
DumpLifted        (CompEnv (Module Type) -> CYIO (CompEnv (Module Type)))
-> CompEnv (Module Type) -> CYIO (CompEnv (Module Type))
forall a b. (a -> b) -> a -> b
$ CompEnv (Module Type) -> CompEnv (Module Type)
lift           CompEnv (Module Type)
simplified
  CompEnv Module
il         <- DumpLevel
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
dumpIL DumpLevel
DumpTranslated    (CompEnv Module
 -> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module))
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
forall a b. (a -> b) -> a -> b
$ CompEnv (Module Type) -> CompEnv Module
ilTrans        CompEnv (Module Type)
lifted
  CompEnv Module
ilCaseComp <- DumpLevel
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
dumpIL DumpLevel
DumpCaseCompleted (CompEnv Module
 -> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module))
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
forall a b. (a -> b) -> a -> b
$ CompEnv Module -> CompEnv Module
completeCase   CompEnv Module
il
  (CompEnv Module, CompEnv (Module Type))
-> CYIO (CompEnv Module, CompEnv (Module Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (CompEnv Module
ilCaseComp, CompEnv (Module Type)
newtypes)
  where
  dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a)
         -> CYIO (CompEnv (CS.Module a))
  dumpCS :: DumpLevel -> CompEnv (Module a) -> CYIO (CompEnv (Module a))
dumpCS = Options
-> (Module a -> FilePath)
-> (Module a -> Doc)
-> DumpLevel
-> CompEnv (Module a)
-> CYIO (CompEnv (Module a))
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts Module a -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule Module a -> Doc
forall a. Module a -> Doc
CS.ppModule
  dumpIL :: DumpLevel
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
dumpIL = Options
-> (Module -> FilePath)
-> (Module -> Doc)
-> DumpLevel
-> CompEnv Module
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv Module)
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts Module -> FilePath
IL.showModule Module -> Doc
IL.ppModule

-- ---------------------------------------------------------------------------
-- Writing output
-- ---------------------------------------------------------------------------

-- The functions \texttt{genFlat} and \texttt{genAbstract} generate
-- flat and abstract curry representations depending on the specified option.
-- If the interface of a modified Curry module did not change, the
-- corresponding file name will be returned within the result of 'genFlat'
-- (depending on the compiler flag "force") and other modules importing this
-- module won't be dependent on it any longer.

writeTokens :: Options -> CompilerEnv -> CYIO ()
writeTokens :: Options -> CompilerEnv -> CYIO ()
writeTokens opts :: Options
opts env :: CompilerEnv
env = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tokTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> FilePath -> IO ()
writeModule (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
tokensName (CompilerEnv -> FilePath
filePath CompilerEnv
env))
              ([(Span, Token)] -> FilePath
showTokenStream (CompilerEnv -> [(Span, Token)]
tokens CompilerEnv
env))
  where
  tokTarget :: Bool
tokTarget  = TargetType
Tokens TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)

writeComments :: Options -> CompilerEnv -> CYIO ()
writeComments :: Options -> CompilerEnv -> CYIO ()
writeComments opts :: Options
opts env :: CompilerEnv
env = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tokTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> FilePath -> IO ()
writeModule (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
commentsName (CompilerEnv -> FilePath
filePath CompilerEnv
env))
              ([(Span, Token)] -> FilePath
showCommentTokenStream ([(Span, Token)] -> FilePath) -> [(Span, Token)] -> FilePath
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> [(Span, Token)]
tokens CompilerEnv
env)
  where
  tokTarget :: Bool
tokTarget  = TargetType
Comments TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)

-- |Output the parsed 'Module' on request
writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO ()
writeParsed :: Options -> CompEnv (Module a) -> CYIO ()
writeParsed opts :: Options
opts (env :: CompilerEnv
env, mdl :: Module a
mdl) = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
srcTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> FilePath -> IO ()
writeModule (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
sourceRepName (CompilerEnv -> FilePath
filePath CompilerEnv
env)) (Module a -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule Module a
mdl)
  where
  srcTarget :: Bool
srcTarget  = TargetType
Parsed TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)

writeHtml :: Options -> CompEnv (CS.Module a) -> CYIO ()
writeHtml :: Options -> CompEnv (Module a) -> CYIO ()
writeHtml opts :: Options
opts (env :: CompilerEnv
env, mdl :: Module a
mdl) = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
htmlTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  Options
-> ModuleIdent -> [(Position, Token)] -> Module a -> CYIO ()
forall a.
Options
-> ModuleIdent -> [(Position, Token)] -> Module a -> CYIO ()
source2html Options
opts (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env) (((Span, Token) -> (Position, Token))
-> [(Span, Token)] -> [(Position, Token)]
forall a b. (a -> b) -> [a] -> [b]
map (\(sp :: Span
sp, tok :: Token
tok) -> (Span -> Position
span2Pos Span
sp, Token
tok)) (CompilerEnv -> [(Span, Token)]
tokens CompilerEnv
env)) Module a
mdl
  where htmlTarget :: Bool
htmlTarget = TargetType
Html TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts

writeInterface :: Options -> CompilerEnv -> CS.Interface -> CYIO ()
writeInterface :: Options -> CompilerEnv -> Interface -> CYIO ()
writeInterface opts :: Options
opts env :: CompilerEnv
env intf :: Interface
intf@(CS.Interface m :: ModuleIdent
m _ _)
  | Options -> Bool
optForce Options
opts = CYIO ()
outputInterface
  | Bool
otherwise     = do
      Bool
equal <- IO Bool -> WriterT [Message] (ExceptT [Message] IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT [Message] (ExceptT [Message] IO) Bool)
-> IO Bool -> WriterT [Message] (ExceptT [Message] IO) Bool
forall a b. (a -> b) -> a -> b
$ IO Bool -> (IOException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
C.catch (FilePath -> Interface -> IO Bool
matchInterface FilePath
interfaceFile Interface
intf)
                        IOException -> IO Bool
ignoreIOException
      Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equal CYIO ()
outputInterface
  where
  ignoreIOException :: C.IOException -> IO Bool
  ignoreIOException :: IOException -> IO Bool
ignoreIOException _ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  interfaceFile :: FilePath
interfaceFile   = FilePath -> FilePath
interfName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
  outputInterface :: CYIO ()
outputInterface = IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeModule
                    (Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) ModuleIdent
m FilePath
interfaceFile)
                    (Doc -> FilePath
forall a. Show a => a -> FilePath
show (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ Interface -> Doc
CS.ppInterface Interface
intf)

matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface :: FilePath -> Interface -> IO Bool
matchInterface ifn :: FilePath
ifn i :: Interface
i = do
  Handle
hdl <- FilePath -> IOMode -> IO Handle
openFile FilePath
ifn IOMode
ReadMode
  FilePath
src <- Handle -> IO FilePath
hGetContents Handle
hdl
  case CYM Interface -> Either [Message] Interface
forall a. CYM a -> Either [Message] a
runCYMIgnWarn (FilePath -> FilePath -> CYM Interface
CS.parseInterface FilePath
ifn FilePath
src) of
    Left  _  -> Handle -> IO ()
hClose Handle
hdl IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Right i' :: Interface
i' -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Interface
i Interface -> Interface -> Bool
`intfEquiv` Interface -> Interface
fixInterface Interface
i')

writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO ()
writeFlat :: Options -> CompilerEnv -> Module Type -> Module -> CYIO ()
writeFlat opts :: Options
opts env :: CompilerEnv
env mdl :: Module Type
mdl il :: Module
il = do
  (_, tfc :: TProg
tfc) <- Options
-> (TProg -> FilePath)
-> (TProg -> Doc)
-> DumpLevel
-> (CompilerEnv, TProg)
-> WriterT [Message] (ExceptT [Message] IO) (CompilerEnv, TProg)
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts TProg -> FilePath
forall a. Show a => a -> FilePath
show (Prog -> Doc
FC.ppProg (Prog -> Doc) -> (TProg -> Prog) -> TProg -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TProg -> Prog
genFlatCurry) DumpLevel
DumpTypedFlatCurry (CompilerEnv
env, TProg
tfcyProg)
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tfcyTarget  (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> AProg TypeExpr -> IO ()
forall a. Show a => FilePath -> a -> IO ()
FC.writeFlatCurry (FilePath -> FilePath
useSubDir FilePath
tfcyName) AProg TypeExpr
tafcyProg
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tafcyTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> TProg -> IO ()
forall a. Show a => FilePath -> a -> IO ()
FC.writeFlatCurry (FilePath -> FilePath
useSubDir FilePath
tafcyName) TProg
tfc
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fcyTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ do
    (_, fc :: Prog
fc) <- Options
-> (Prog -> FilePath)
-> (Prog -> Doc)
-> DumpLevel
-> (CompilerEnv, Prog)
-> WriterT [Message] (ExceptT [Message] IO) (CompilerEnv, Prog)
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts Prog -> FilePath
forall a. Show a => a -> FilePath
show Prog -> Doc
FC.ppProg DumpLevel
DumpFlatCurry (CompilerEnv
env, Prog
fcyProg)
    IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Prog -> IO ()
forall a. Show a => FilePath -> a -> IO ()
FC.writeFlatCurry (FilePath -> FilePath
useSubDir FilePath
fcyName) Prog
fc
  Options -> CompilerEnv -> Prog -> CYIO ()
writeFlatIntf Options
opts CompilerEnv
env Prog
fcyProg
  where
  tfcyName :: FilePath
tfcyName    = FilePath -> FilePath
typedFlatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
  tfcyProg :: TProg
tfcyProg    = CompilerEnv -> Module Type -> Module -> TProg
genTypedFlatCurry CompilerEnv
env Module Type
mdl Module
il
  tfcyTarget :: Bool
tfcyTarget  = TargetType
TypedFlatCurry TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  tafcyName :: FilePath
tafcyName   = FilePath -> FilePath
typeAnnFlatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
  tafcyProg :: AProg TypeExpr
tafcyProg   = CompilerEnv -> Module Type -> Module -> AProg TypeExpr
genTypeAnnotatedFlatCurry CompilerEnv
env Module Type
mdl Module
il
  tafcyTarget :: Bool
tafcyTarget = TargetType
TypeAnnotatedFlatCurry TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  fcyName :: FilePath
fcyName     = FilePath -> FilePath
flatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
  fcyProg :: Prog
fcyProg     = TProg -> Prog
genFlatCurry TProg
tfcyProg
  fcyTarget :: Bool
fcyTarget   = TargetType
FlatCurry TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir   = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)

writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO ()
writeFlatIntf :: Options -> CompilerEnv -> Prog -> CYIO ()
writeFlatIntf opts :: Options
opts env :: CompilerEnv
env prog :: Prog
prog
  | Bool -> Bool
not (Options -> Bool
optInterface Options
opts) = () -> CYIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Options -> Bool
optForce Options
opts           = CYIO ()
outputInterface
  | Bool
otherwise               = do
      Maybe Prog
mfint <- IO (Maybe Prog)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe Prog)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Prog)
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe Prog))
-> IO (Maybe Prog)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe Prog)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe Prog)
FC.readFlatInterface FilePath
targetFile
      let oldInterface :: Prog
oldInterface = Prog -> Maybe Prog -> Prog
forall a. a -> Maybe a -> a
fromMaybe Prog
emptyIntf Maybe Prog
mfint
      Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Prog
mfint Maybe Prog -> Maybe Prog -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Prog
mfint) (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ () -> CYIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- necessary to close file -- TODO
      Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Prog
oldInterface Prog -> Prog -> Bool
`eqInterface` Prog
fint) CYIO ()
outputInterface
  where
  targetFile :: FilePath
targetFile      = FilePath -> FilePath
flatIntName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
  emptyIntf :: Prog
emptyIntf       = FilePath
-> [FilePath] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> Prog
FC.Prog "" [] [] [] []
  fint :: Prog
fint            = Prog -> Prog
genFlatInterface Prog
prog
  useSubDir :: FilePath -> FilePath
useSubDir       = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)
  outputInterface :: CYIO ()
outputInterface = IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Prog -> IO ()
forall a. Show a => FilePath -> a -> IO ()
FC.writeFlatCurry (FilePath -> FilePath
useSubDir FilePath
targetFile) Prog
fint

writeAbstractCurry :: Options -> CompEnv (CS.Module PredType) -> CYIO ()
writeAbstractCurry :: Options -> CompEnv (Module PredType) -> CYIO ()
writeAbstractCurry opts :: Options
opts (env :: CompilerEnv
env, mdl :: Module PredType
mdl) = do
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
acyTarget  (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                  (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CurryProg -> IO ()
AC.writeCurry (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
acyName (CompilerEnv -> FilePath
filePath CompilerEnv
env))
                  (CurryProg -> IO ()) -> CurryProg -> IO ()
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> Module PredType -> CurryProg
genTypedAbstractCurry CompilerEnv
env Module PredType
mdl
  Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
uacyTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                  (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CurryProg -> IO ()
AC.writeCurry (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
uacyName (CompilerEnv -> FilePath
filePath CompilerEnv
env))
                  (CurryProg -> IO ()) -> CurryProg -> IO ()
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> Module PredType -> CurryProg
genUntypedAbstractCurry CompilerEnv
env Module PredType
mdl
  where
  acyTarget :: Bool
acyTarget  = TargetType
AbstractCurry        TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  uacyTarget :: Bool
uacyTarget = TargetType
UntypedAbstractCurry TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)


writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()
writeAST :: Options -> CompEnv (Module ()) -> CYIO ()
writeAST opts :: Options
opts (env :: CompilerEnv
env, mdl :: Module ()
mdl) = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
astTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> FilePath -> IO ()
writeModule (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
astName (CompilerEnv -> FilePath
filePath CompilerEnv
env)) (Module () -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule Module ()
mdl)
  where
  astTarget :: Bool
astTarget  = TargetType
AST TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)


writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()
writeShortAST :: Options -> CompEnv (Module ()) -> CYIO ()
writeShortAST opts :: Options
opts (env :: CompilerEnv
env, mdl :: Module ()
mdl) = Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
astTarget (CYIO () -> CYIO ()) -> CYIO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> CYIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CYIO ()) -> IO () -> CYIO ()
forall a b. (a -> b) -> a -> b
$
  FilePath -> FilePath -> IO ()
writeModule (FilePath -> FilePath
useSubDir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
shortASTName (CompilerEnv -> FilePath
filePath CompilerEnv
env))
              (Module () -> FilePath
forall a. Show a => Module a -> FilePath
CS.showModule (Module () -> FilePath) -> Module () -> FilePath
forall a b. (a -> b) -> a -> b
$ Module () -> Module ()
shortenModuleAST Module ()
mdl)
  where
  astTarget :: Bool
astTarget  = TargetType
ShortAST TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
  useSubDir :: FilePath -> FilePath
useSubDir  = Bool -> ModuleIdent -> FilePath -> FilePath
addCurrySubdirModule (Options -> Bool
optUseSubdir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)


type Dump = (DumpLevel, CompilerEnv, String)

dumpWith :: MonadIO m
         => Options -> (a -> String) -> (a -> Doc) -> DumpLevel
         -> CompEnv a -> m (CompEnv a)
dumpWith :: Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith opts :: Options
opts rawView :: a -> FilePath
rawView view :: a -> Doc
view lvl :: DumpLevel
lvl res :: CompEnv a
res@(env :: CompilerEnv
env, mdl :: a
mdl) = do
  let str :: FilePath
str = if DebugOpts -> Bool
dbDumpRaw (Options -> DebugOpts
optDebugOpts Options
opts) then a -> FilePath
rawView a
mdl
                                             else Doc -> FilePath
forall a. Show a => a -> FilePath
show (a -> Doc
view a
mdl)
  DebugOpts -> Dump -> m ()
forall (m :: * -> *). MonadIO m => DebugOpts -> Dump -> m ()
doDump (Options -> DebugOpts
optDebugOpts Options
opts) (DumpLevel
lvl, CompilerEnv
env, FilePath
str)
  CompEnv a -> m (CompEnv a)
forall (m :: * -> *) a. Monad m => a -> m a
return CompEnv a
res

-- |Translate FlatCurry into the intermediate language 'IL'
-- |The 'dump' function writes the selected information to standard output.
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump :: DebugOpts -> Dump -> m ()
doDump opts :: DebugOpts
opts (level :: DumpLevel
level, env :: CompilerEnv
env, dump :: FilePath
dump)
  = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpLevel
level DumpLevel -> [DumpLevel] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DebugOpts -> [DumpLevel]
dbDumpLevels DebugOpts
opts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> IO ()
putStrLn (FilePath -> Char -> FilePath
heading (FilePath -> FilePath
capitalize (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ [(DumpLevel, FilePath, FilePath)] -> FilePath
forall b. [(DumpLevel, b, FilePath)] -> FilePath
lookupHeader [(DumpLevel, FilePath, FilePath)]
dumpLevel) '=')
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DebugOpts -> Bool
dbDumpEnv DebugOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath -> IO ()
putStrLn (FilePath -> Char -> FilePath
heading "Environment" '-')
        FilePath -> IO ()
putStrLn (CompilerEnv -> Bool -> Bool -> FilePath
showCompilerEnv CompilerEnv
env (DebugOpts -> Bool
dbDumpAllBindings DebugOpts
opts) (DebugOpts -> Bool
dbDumpSimple DebugOpts
opts))
      FilePath -> IO ()
putStrLn (FilePath -> Char -> FilePath
heading "Source Code" '-')
      FilePath -> IO ()
putStrLn FilePath
dump
  where
  heading :: FilePath -> Char -> FilePath
heading h :: FilePath
h s :: Char
s = '\n' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ '\n' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
h) Char
s
  lookupHeader :: [(DumpLevel, b, FilePath)] -> FilePath
lookupHeader []            = "Unknown dump level " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DumpLevel -> FilePath
forall a. Show a => a -> FilePath
show DumpLevel
level
  lookupHeader ((l :: DumpLevel
l,_,h :: FilePath
h):lhs :: [(DumpLevel, b, FilePath)]
lhs)
    | DumpLevel
level DumpLevel -> DumpLevel -> Bool
forall a. Eq a => a -> a -> Bool
== DumpLevel
l = FilePath
h
    | Bool
otherwise  = [(DumpLevel, b, FilePath)] -> FilePath
lookupHeader [(DumpLevel, b, FilePath)]
lhs
  capitalize :: FilePath -> FilePath
capitalize = [FilePath] -> FilePath
unwords ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
firstUpper ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words
  firstUpper :: FilePath -> FilePath
firstUpper ""     = ""
  firstUpper (c :: Char
c:cs :: FilePath
cs) = Char -> Char
toUpper Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
cs

errModuleFileMismatch :: ModuleIdent -> Message
errModuleFileMismatch :: ModuleIdent -> Message
errModuleFileMismatch mid :: ModuleIdent
mid = ModuleIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage ModuleIdent
mid (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (FilePath -> Doc) -> [FilePath] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Doc
text
  [ "Module", ModuleIdent -> FilePath
moduleName ModuleIdent
mid, "must be in a file"
  , ModuleIdent -> FilePath
moduleName ModuleIdent
mid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".(l)curry" ]