{-# 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)
type IntfLoader a = S.StateT LoaderState IO a
data LoaderState = LoaderState
{ LoaderState -> InterfaceEnv
iEnv :: InterfaceEnv
, LoaderState -> [FilePath]
spaths :: [FilePath]
, LoaderState -> [Message]
errs :: [Message]
}
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 }
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
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
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 }
loadInterfaces :: [FilePath]
-> Module a
-> 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]
loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent)
-> IntfLoader ()
loadInterface :: [ModuleIdent] -> (a, ModuleIdent) -> IntfLoader ()
loadInterface ctxt :: [ModuleIdent]
ctxt (_, 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 [[ModuleIdent] -> Message
errCyclicImport ([ModuleIdent] -> Message) -> [ModuleIdent] -> Message
forall a b. (a -> b) -> a -> b
$ 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 [ModuleIdent -> Message
errInterfaceNotFound ModuleIdent
m]
Just fn :: FilePath
fn -> [ModuleIdent] -> ModuleIdent -> FilePath -> IntfLoader ()
compileInterface [ModuleIdent]
ctxt ModuleIdent
m FilePath
fn
compileInterface :: [ModuleIdent] -> ModuleIdent -> FilePath
-> IntfLoader ()
compileInterface :: [ModuleIdent] -> ModuleIdent -> FilePath -> IntfLoader ()
compileInterface ctxt :: [ModuleIdent]
ctxt 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 [ModuleIdent -> Message
errInterfaceNotFound 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 [ModuleIdent -> ModuleIdent -> Message
errWrongInterface 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'
errInterfaceNotFound :: ModuleIdent -> Message
errInterfaceNotFound :: ModuleIdent -> Message
errInterfaceNotFound m :: ModuleIdent
m = ModuleIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage ModuleIdent
m (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"
errWrongInterface :: ModuleIdent -> ModuleIdent -> Message
errWrongInterface :: ModuleIdent -> ModuleIdent -> Message
errWrongInterface m :: ModuleIdent
m n :: ModuleIdent
n = ModuleIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage ModuleIdent
m (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)
errCyclicImport :: [ModuleIdent] -> Message
errCyclicImport :: [ModuleIdent] -> Message
errCyclicImport [] = FilePath -> Message
forall a. FilePath -> a
internalError "Interfaces.errCyclicImport: empty list"
errCyclicImport [m :: ModuleIdent
m] = ModuleIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage ModuleIdent
m (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 ms :: [ModuleIdent]
ms = ModuleIdent -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage ([ModuleIdent] -> ModuleIdent
forall a. [a] -> a
head [ModuleIdent]
ms) (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)