{- |
    Module      :  $Header$
    Description :  Loading interfaces
    Copyright   :  (c) 2000 - 2004, Wolfgang Lux
                       2011 - 2013, Björn Peemöller
    License     :  BSD-3-clause

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

    The compiler maintains a global environment holding all (directly or
    indirectly) imported interface declarations for a module.

    This module contains a function to load *all* interface declarations
    declared by the (directly or indirectly) imported modules, regardless
    whether they are included by the import specification or not.

    The declarations are later brought into the scope of the module via the
    function 'importModules', see module "Imports".

    Interface files are updated by the Curry builder when necessary,
    see module "CurryBuilder".
-}
{-# LANGUAGE CPP #-}
module Interfaces (loadInterfaces) where

#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

import           Control.Monad               (unless)
import qualified Control.Monad.State    as S (StateT, execStateT, gets, modify)
import qualified Data.Map               as M (insert, member)

import           Curry.Base.Ident
import           Curry.Base.Monad
import           Curry.Base.Position
import           Curry.Base.SpanInfo ()
import           Curry.Base.Pretty
import           Curry.Files.PathUtils
import           Curry.Syntax

import Base.Messages
import Env.Interface

import Checks.InterfaceSyntaxCheck (intfSyntaxCheck)

-- Interface accumulating monad
type IntfLoader a = S.StateT LoaderState IO a

data LoaderState = LoaderState
  { LoaderState -> InterfaceEnv
iEnv   :: InterfaceEnv
  , LoaderState -> [FilePath]
spaths :: [FilePath]
  , LoaderState -> [Message]
errs   :: [Message]
  }

-- Report an error.
report :: [Message] -> IntfLoader ()
report :: [Message] -> IntfLoader ()
report msg :: [Message]
msg = (LoaderState -> LoaderState) -> IntfLoader ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((LoaderState -> LoaderState) -> IntfLoader ())
-> (LoaderState -> LoaderState) -> IntfLoader ()
forall a b. (a -> b) -> a -> b
$ \ s :: LoaderState
s -> LoaderState
s { errs :: [Message]
errs = [Message]
msg [Message] -> [Message] -> [Message]
forall a. [a] -> [a] -> [a]
++ LoaderState -> [Message]
errs LoaderState
s }

-- Check whether a module interface is already loaded.
loaded :: ModuleIdent -> IntfLoader Bool
loaded :: ModuleIdent -> IntfLoader Bool
loaded m :: ModuleIdent
m = (LoaderState -> Bool) -> IntfLoader Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((LoaderState -> Bool) -> IntfLoader Bool)
-> (LoaderState -> Bool) -> IntfLoader Bool
forall a b. (a -> b) -> a -> b
$ \ s :: LoaderState
s -> ModuleIdent
m ModuleIdent -> InterfaceEnv -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` LoaderState -> InterfaceEnv
iEnv LoaderState
s

-- Retrieve the search paths
searchPaths :: IntfLoader [FilePath]
searchPaths :: IntfLoader [FilePath]
searchPaths = (LoaderState -> [FilePath]) -> IntfLoader [FilePath]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets LoaderState -> [FilePath]
spaths

-- Add an interface to the environment.
addInterface :: ModuleIdent -> Interface -> IntfLoader ()
addInterface :: ModuleIdent -> Interface -> IntfLoader ()
addInterface m :: ModuleIdent
m intf :: Interface
intf = (LoaderState -> LoaderState) -> IntfLoader ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((LoaderState -> LoaderState) -> IntfLoader ())
-> (LoaderState -> LoaderState) -> IntfLoader ()
forall a b. (a -> b) -> a -> b
$ \ s :: LoaderState
s -> LoaderState
s { iEnv :: InterfaceEnv
iEnv = ModuleIdent -> Interface -> InterfaceEnv -> InterfaceEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleIdent
m Interface
intf (InterfaceEnv -> InterfaceEnv) -> InterfaceEnv -> InterfaceEnv
forall a b. (a -> b) -> a -> b
$ LoaderState -> InterfaceEnv
iEnv LoaderState
s }

-- |Load the interfaces needed by a given module.
-- This function returns an 'InterfaceEnv' containing the 'Interface's which
-- were successfully loaded.
loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces
               -> Module a   -- ^ 'Module' header with import declarations
               -> CYIO InterfaceEnv
loadInterfaces :: [FilePath] -> Module a -> CYIO InterfaceEnv
loadInterfaces paths :: [FilePath]
paths (Module _ _ m :: ModuleIdent
m _ is :: [ImportDecl]
is _) = do
  LoaderState
res <- IO LoaderState
-> WriterT [Message] (ExceptT [Message] IO) LoaderState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LoaderState
 -> WriterT [Message] (ExceptT [Message] IO) LoaderState)
-> IO LoaderState
-> WriterT [Message] (ExceptT [Message] IO) LoaderState
forall a b. (a -> b) -> a -> b
$ IntfLoader () -> LoaderState -> IO LoaderState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
S.execStateT IntfLoader ()
load (InterfaceEnv -> [FilePath] -> [Message] -> LoaderState
LoaderState InterfaceEnv
initInterfaceEnv [FilePath]
paths [])
  if [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LoaderState -> [Message]
errs LoaderState
res) then InterfaceEnv -> CYIO InterfaceEnv
forall (m :: * -> *) a. Monad m => a -> CYT m a
ok (LoaderState -> InterfaceEnv
iEnv LoaderState
res) else [Message] -> CYIO InterfaceEnv
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages ([Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ LoaderState -> [Message]
errs LoaderState
res)
  where load :: IntfLoader ()
load = ((SpanInfo, ModuleIdent) -> IntfLoader ())
-> [(SpanInfo, ModuleIdent)] -> IntfLoader ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ModuleIdent] -> (SpanInfo, ModuleIdent) -> IntfLoader ()
forall a.
HasPosition a =>
[ModuleIdent] -> (a, ModuleIdent) -> IntfLoader ()
loadInterface [ModuleIdent
m]) [(SpanInfo
p, ModuleIdent
m') | ImportDecl p :: SpanInfo
p m' :: ModuleIdent
m' _ _ _ <- [ImportDecl]
is]

-- |Load an interface into the given environment.
--
-- If an import declaration for a module is found, the compiler first
-- checks whether an import for the module is already pending.
-- In this case the module imports are cyclic which is not allowed in Curry.
-- Therefore, the import will be skipped and an error will be issued.
-- Otherwise, the compiler checks whether the module has already been imported.
-- If so, nothing needs to be done, otherwise the interface will be searched
-- for in the import paths and compiled.
loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent)
              -> IntfLoader ()
loadInterface :: [ModuleIdent] -> (a, ModuleIdent) -> IntfLoader ()
loadInterface ctxt :: [ModuleIdent]
ctxt imp :: (a, ModuleIdent)
imp@(pp :: a
pp, m :: ModuleIdent
m)
  | ModuleIdent
m ModuleIdent -> [ModuleIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleIdent]
ctxt = [Message] -> IntfLoader ()
report [Position -> [ModuleIdent] -> Message
forall p. HasPosition p => p -> [ModuleIdent] -> Message
errCyclicImport Position
p (ModuleIdent
m ModuleIdent -> [ModuleIdent] -> [ModuleIdent]
forall a. a -> [a] -> [a]
: (ModuleIdent -> Bool) -> [ModuleIdent] -> [ModuleIdent]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleIdent
m) [ModuleIdent]
ctxt)]
  | Bool
otherwise     = do
    Bool
isLoaded <- ModuleIdent -> IntfLoader Bool
loaded ModuleIdent
m
    Bool -> IntfLoader () -> IntfLoader ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isLoaded (IntfLoader () -> IntfLoader ()) -> IntfLoader () -> IntfLoader ()
forall a b. (a -> b) -> a -> b
$ do
      [FilePath]
paths  <- IntfLoader [FilePath]
searchPaths
      Maybe FilePath
mbIntf <- IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath))
-> IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
lookupCurryInterface [FilePath]
paths ModuleIdent
m
      case Maybe FilePath
mbIntf of
        Nothing -> [Message] -> IntfLoader ()
report [Position -> ModuleIdent -> Message
forall p. HasPosition p => p -> ModuleIdent -> Message
errInterfaceNotFound Position
p ModuleIdent
m]
        Just fn :: FilePath
fn -> [ModuleIdent] -> (a, ModuleIdent) -> FilePath -> IntfLoader ()
forall p.
HasPosition p =>
[ModuleIdent] -> (p, ModuleIdent) -> FilePath -> IntfLoader ()
compileInterface [ModuleIdent]
ctxt (a, ModuleIdent)
imp FilePath
fn
  where p :: Position
p = a -> Position
forall a. HasPosition a => a -> Position
getPosition a
pp

-- |Compile an interface by recursively loading its dependencies.
--
-- After reading an interface, all imported interfaces are recursively
-- loaded and inserted into the interface's environment.
compileInterface :: HasPosition p => [ModuleIdent] -> (p, ModuleIdent) -> FilePath
                 -> IntfLoader ()
compileInterface :: [ModuleIdent] -> (p, ModuleIdent) -> FilePath -> IntfLoader ()
compileInterface ctxt :: [ModuleIdent]
ctxt (p :: p
p, m :: ModuleIdent
m) fn :: FilePath
fn = do
  Maybe FilePath
mbSrc <- IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath))
-> IO (Maybe FilePath) -> StateT LoaderState IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
readModule FilePath
fn
  case Maybe FilePath
mbSrc of
    Nothing  -> [Message] -> IntfLoader ()
report [p -> ModuleIdent -> Message
forall p. HasPosition p => p -> ModuleIdent -> Message
errInterfaceNotFound p
p ModuleIdent
m]
    Just src :: FilePath
src -> case CYM Interface -> Either [Message] Interface
forall a. CYM a -> Either [Message] a
runCYMIgnWarn (FilePath -> FilePath -> CYM Interface
parseInterface FilePath
fn FilePath
src) of
      Left err :: [Message]
err -> [Message] -> IntfLoader ()
report [Message]
err
      Right intf :: Interface
intf@(Interface n :: ModuleIdent
n is :: [IImportDecl]
is _) ->
        if ModuleIdent
m ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleIdent
n
          then [Message] -> IntfLoader ()
report [Position -> ModuleIdent -> ModuleIdent -> Message
forall p.
HasPosition p =>
p -> ModuleIdent -> ModuleIdent -> Message
errWrongInterface (FilePath -> Position
first FilePath
fn) ModuleIdent
m ModuleIdent
n]
          else do
            let (intf' :: Interface
intf', intfErrs :: [Message]
intfErrs) = Interface -> (Interface, [Message])
intfSyntaxCheck Interface
intf
            ([Message] -> IntfLoader ()) -> [[Message]] -> IntfLoader ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Message] -> IntfLoader ()
report [[Message]
intfErrs]
            ((Position, ModuleIdent) -> IntfLoader ())
-> [(Position, ModuleIdent)] -> IntfLoader ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([ModuleIdent] -> (Position, ModuleIdent) -> IntfLoader ()
forall a.
HasPosition a =>
[ModuleIdent] -> (a, ModuleIdent) -> IntfLoader ()
loadInterface (ModuleIdent
m ModuleIdent -> [ModuleIdent] -> [ModuleIdent]
forall a. a -> [a] -> [a]
: [ModuleIdent]
ctxt)) [ (Position
q, ModuleIdent
i) | IImportDecl q :: Position
q i :: ModuleIdent
i <- [IImportDecl]
is ]
            ModuleIdent -> Interface -> IntfLoader ()
addInterface ModuleIdent
m Interface
intf'

-- Error message for required interface that could not be found.
errInterfaceNotFound :: HasPosition p => p -> ModuleIdent -> Message
errInterfaceNotFound :: p -> ModuleIdent -> Message
errInterfaceNotFound p :: p
p m :: ModuleIdent
m = p -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage p
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  FilePath -> Doc
text "Interface for module" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (ModuleIdent -> FilePath
moduleName ModuleIdent
m) Doc -> Doc -> Doc
<+> FilePath -> Doc
text "not found"

-- Error message for an unexpected interface.
errWrongInterface :: HasPosition p => p -> ModuleIdent -> ModuleIdent -> Message
errWrongInterface :: p -> ModuleIdent -> ModuleIdent -> Message
errWrongInterface p :: p
p m :: ModuleIdent
m n :: ModuleIdent
n = p -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage p
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  FilePath -> Doc
text "Expected interface for" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (ModuleIdent -> FilePath
moduleName ModuleIdent
m)
  Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> FilePath -> Doc
text "but found" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (ModuleIdent -> FilePath
moduleName ModuleIdent
n)

-- Error message for a cyclic import.
errCyclicImport :: HasPosition p => p -> [ModuleIdent] -> Message
errCyclicImport :: p -> [ModuleIdent] -> Message
errCyclicImport _ []  = FilePath -> Message
forall a. FilePath -> a
internalError "Interfaces.errCyclicImport: empty list"
errCyclicImport p :: p
p [m :: ModuleIdent
m] = p -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage p
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  FilePath -> Doc
text "Recursive import for module" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (ModuleIdent -> FilePath
moduleName ModuleIdent
m)
errCyclicImport p :: p
p ms :: [ModuleIdent]
ms  = p -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage p
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  FilePath -> Doc
text "Cyclic import dependency between modules"
  Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((FilePath -> Doc) -> [FilePath] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Doc
text [FilePath]
inits)) Doc -> Doc -> Doc
<+> FilePath -> Doc
text "and" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
lastm
  where
  (inits :: [FilePath]
inits, lastm :: FilePath
lastm)         = [FilePath] -> ([FilePath], FilePath)
forall a. [a] -> ([a], a)
splitLast ([FilePath] -> ([FilePath], FilePath))
-> [FilePath] -> ([FilePath], FilePath)
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> FilePath) -> [ModuleIdent] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ModuleIdent -> FilePath
moduleName [ModuleIdent]
ms
  splitLast :: [a] -> ([a], a)
splitLast []           = FilePath -> ([a], a)
forall a. FilePath -> a
internalError "Interfaces.splitLast: empty list"
  splitLast (x :: a
x : [])     = ([]  , a
x)
  splitLast (x :: a
x : y :: a
y : ys :: [a]
ys) = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, a
z) where (xs :: [a]
xs, z :: a
z) = [a] -> ([a], a)
splitLast (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)