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
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
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. Pretty a => a -> Doc
pPrint 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'
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
AnnotatedFlatCurry
, 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
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
(toks :: [(Span, Token)]
toks, mdl :: Module ()
mdl) <- Options
-> ModuleIdent -> FilePath -> CYIO ([(Span, Token)], Module ())
parseModule Options
opts ModuleIdent
m FilePath
fn
let paths :: [FilePath]
paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> FilePath -> FilePath -> FilePath
addOutDir (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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
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)
[(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 ())
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
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']
importPrelude :: Options -> CS.Module () -> CS.Module ()
importPrelude :: Options -> Module () -> Module ()
importPrelude opts :: Options
opts m :: Module ()
m@(CS.Module spi :: SpanInfo
spi li :: LayoutInfo
li ps :: [ModulePragma]
ps mid :: ModuleIdent
mid es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl ()]
ds)
| ModuleIdent
mid ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
preludeMIdent = Module ()
m
| Bool
noImpPrelude = Module ()
m
| ModuleIdent
preludeMIdent ModuleIdent -> [ModuleIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleIdent]
imports = Module ()
m
| Bool
otherwise = SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl ()]
-> Module ()
forall a.
SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
CS.Module SpanInfo
spi LayoutInfo
li [ModulePragma]
ps ModuleIdent
mid Maybe ExportSpec
es (ImportDecl
preludeImpImportDecl -> [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
Maybe ModuleIdent
forall a. Maybe a
Nothing
Maybe ImportSpec
forall a. Maybe a
Nothing
imports :: [ModuleIdent]
imports = [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
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. Pretty a => a -> Doc
pPrint
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
$ Bool -> CompEnv (Module PredType) -> CompEnv (Module Type)
insertDicts Bool
inlDi 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
$ Bool -> CompEnv (Module Type) -> CompEnv (Module Type)
removeNewtypes Bool
remNT 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
$ Bool -> CompEnv (Module Type) -> CompEnv Module
ilTrans Bool
remIm 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
optOpts :: OptimizationOpts
optOpts = Options -> OptimizationOpts
optOptimizations Options
opts
inlDi :: Bool
inlDi = OptimizationOpts -> Bool
optInlineDictionaries OptimizationOpts
optOpts
remIm :: Bool
remIm = OptimizationOpts -> Bool
optRemoveUnusedImports OptimizationOpts
optOpts
remNT :: Bool
remNT = OptimizationOpts -> Bool
optDesugarNewtypes OptimizationOpts
optOpts
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. Pretty a => a -> Doc
pPrint
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
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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)
writeComments :: Options -> CompilerEnv -> CYIO ()
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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir Options
opts) (CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env)
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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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
forall a. Pretty a => a -> Doc
pPrint 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
CompEnv (AProg TypeExpr)
_ <- Options
-> (AProg TypeExpr -> FilePath)
-> (AProg TypeExpr -> Doc)
-> DumpLevel
-> CompEnv (AProg TypeExpr)
-> WriterT
[Message] (ExceptT [Message] IO) (CompEnv (AProg TypeExpr))
forall (m :: * -> *) a.
MonadIO m =>
Options
-> (a -> FilePath)
-> (a -> Doc)
-> DumpLevel
-> CompEnv a
-> m (CompEnv a)
dumpWith Options
opts AProg TypeExpr -> FilePath
forall a. Show a => a -> FilePath
show (Prog -> Doc
forall a. Pretty a => a -> Doc
pPrint (Prog -> Doc) -> (AProg TypeExpr -> Prog) -> AProg TypeExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AProg TypeExpr -> Prog
genFlatCurry) DumpLevel
DumpTypedFlatCurry (CompilerEnv
env, AProg TypeExpr
afcy)
Bool -> CYIO () -> CYIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
afcyTarget (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
afcyName) AProg TypeExpr
afcy
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 -> TProg -> IO ()
forall a. Show a => FilePath -> a -> IO ()
FC.writeFlatCurry (FilePath -> FilePath
useSubDir FilePath
tfcyName) TProg
tfcy
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
CompEnv Prog
_ <- Options
-> (Prog -> FilePath)
-> (Prog -> Doc)
-> DumpLevel
-> CompEnv Prog
-> WriterT [Message] (ExceptT [Message] IO) (CompEnv 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
forall a. Pretty a => a -> Doc
pPrint DumpLevel
DumpFlatCurry (CompilerEnv
env, Prog
fcy)
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
fcy
Options -> CompilerEnv -> Prog -> CYIO ()
writeFlatIntf Options
opts CompilerEnv
env Prog
fcy
where
afcy :: AProg TypeExpr
afcy = CompilerEnv -> Module Type -> Module -> AProg TypeExpr
genAnnotatedFlatCurry CompilerEnv
env Module Type
mdl Module
il
afcyName :: FilePath
afcyName = FilePath -> FilePath
annotatedFlatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
afcyTarget :: Bool
afcyTarget = TargetType
AnnotatedFlatCurry TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts
tfcy :: TProg
tfcy = AProg TypeExpr -> TProg
genTypedFlatCurry AProg TypeExpr
afcy
tfcyName :: FilePath
tfcyName = FilePath -> FilePath
typedFlatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
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
fcy :: Prog
fcy = AProg TypeExpr -> Prog
genFlatCurry AProg TypeExpr
afcy
fcyName :: FilePath
fcyName = FilePath -> FilePath
flatName (CompilerEnv -> FilePath
filePath CompilerEnv
env)
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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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 ()
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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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 -> FilePath -> ModuleIdent -> FilePath -> FilePath
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> FilePath
optOutDir 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
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" ]