{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
-- | The IR-agnostic part of the HSE front end: locating, parsing, and
--   caching modules and (recursively) their imports. The per-module
--   pipeline (desugaring and translation out of the HSE AST) is supplied
--   by the caller; the embedder instantiates it for Atmo (see
--   "Embedder.ModCache").
module ReWire.HSE.Cache
      ( Cache
      , LoadPath
      , runCache
      , getModuleWith
      ) where

import ReWire.Annotation (Annotation)
import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)
import ReWire.Config (Config, loadPath, pDebug)
import ReWire.Error (failAt, AstError, MonadError, filePath, relocatingTo)
import ReWire.HSE.Desugar (addMainModuleHead)
import ReWire.HSE.Parse (tryParseInDir)
import ReWire.HSE.Rename (Exports, Renamer, fromImps, toFilePath)
import ReWire.HSE.Globs (extendWithGlobs, getImps)
import ReWire.Pretty (showt)

import Control.Arrow ((***))
import Control.Lens ((^.))
import Control.Monad (msum, void)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State.Strict (runStateT, StateT, MonadState (..), modify)
import Data.HashMap.Strict (HashMap)
import Data.Text (pack)
import Language.Haskell.Exts.Syntax (ImportDecl (..))
import System.FilePath ((</>), takeDirectory)

import qualified Data.HashMap.Strict          as Map
import qualified Language.Haskell.Exts.Syntax as S (Module (..))

type LoadPath = [FilePath]
type Cache mod m = StateT (HashMap FilePath (mod, Exports)) m

runCache :: Monad m => Cache mod m a -> m a
runCache :: forall (m :: * -> *) mod a. Monad m => Cache mod m a -> m a
runCache Cache mod m a
m = (a, HashMap FilePath (mod, Exports)) -> a
forall a b. (a, b) -> a
fst ((a, HashMap FilePath (mod, Exports)) -> a)
-> m (a, HashMap FilePath (mod, Exports)) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache mod m a
-> HashMap FilePath (mod, Exports)
-> m (a, HashMap FilePath (mod, Exports))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Cache mod m a
m HashMap FilePath (mod, Exports)
forall a. Monoid a => a
mempty

-- | Locates a module in the load path, parses it, loads its imports
--   (recursively, with caching), and runs the supplied translation, which
--   takes the module's file path, renamer, loaded imports, and HSE AST to
--   the target IR. The translation's result is cached per file path.
getModuleWith :: forall mod m. (MonadIO m, MonadError AstError m, Monoid mod)
      => (FilePath -> Renamer -> mod -> S.Module SrcSpanInfo -> Cache mod m (mod, Exports))
      -> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
getModuleWith :: forall mod (m :: * -> *).
(MonadIO m, MonadError AstError m, Monoid mod) =>
(FilePath
 -> Renamer
 -> mod
 -> Module SrcSpanInfo
 -> Cache mod m (mod, Exports))
-> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
getModuleWith FilePath
-> Renamer
-> mod
-> Module SrcSpanInfo
-> Cache mod m (mod, Exports)
translate Config
conf FilePath
pwd FilePath
fp = Config -> Text -> StateT (HashMap FilePath (mod, Exports)) m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf (Text
"Fetching module: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (pwd: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack FilePath
pwd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") StateT (HashMap FilePath (mod, Exports)) m ()
-> StateT
     (HashMap FilePath (mod, Exports)) m (Maybe (mod, Exports))
-> StateT
     (HashMap FilePath (mod, Exports)) m (Maybe (mod, Exports))
forall a b.
StateT (HashMap FilePath (mod, Exports)) m a
-> StateT (HashMap FilePath (mod, Exports)) m b
-> StateT (HashMap FilePath (mod, Exports)) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> HashMap FilePath (mod, Exports) -> Maybe (mod, Exports)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup FilePath
fp (HashMap FilePath (mod, Exports) -> Maybe (mod, Exports))
-> StateT
     (HashMap FilePath (mod, Exports))
     m
     (HashMap FilePath (mod, Exports))
-> StateT
     (HashMap FilePath (mod, Exports)) m (Maybe (mod, Exports))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT
  (HashMap FilePath (mod, Exports))
  m
  (HashMap FilePath (mod, Exports))
forall s (m :: * -> *). MonadState s m => m s
get StateT (HashMap FilePath (mod, Exports)) m (Maybe (mod, Exports))
-> (Maybe (mod, Exports) -> Cache mod m (mod, Exports))
-> Cache mod m (mod, Exports)
forall a b.
StateT (HashMap FilePath (mod, Exports)) m a
-> (a -> StateT (HashMap FilePath (mod, Exports)) m b)
-> StateT (HashMap FilePath (mod, Exports)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Just (mod, Exports)
p  -> (mod, Exports) -> Cache mod m (mod, Exports)
forall a. a -> StateT (HashMap FilePath (mod, Exports)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (mod, Exports)
p
      Maybe (mod, Exports)
Nothing -> do
            (HashMap FilePath (mod, Exports)
 -> HashMap FilePath (mod, Exports))
-> StateT (HashMap FilePath (mod, Exports)) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HashMap FilePath (mod, Exports)
  -> HashMap FilePath (mod, Exports))
 -> StateT (HashMap FilePath (mod, Exports)) m ())
-> (HashMap FilePath (mod, Exports)
    -> HashMap FilePath (mod, Exports))
-> StateT (HashMap FilePath (mod, Exports)) m ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> (mod, Exports)
-> HashMap FilePath (mod, Exports)
-> HashMap FilePath (mod, Exports)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert FilePath
fp (mod, Exports)
forall a. Monoid a => a
mempty

            let lp :: [FilePath]
lp     = FilePath
pwd FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Config
confConfig -> Getting [FilePath] Config [FilePath] -> [FilePath]
forall s a. s -> Getting a s a -> a
^.Getting [FilePath] Config [FilePath]
Lens' Config [FilePath]
loadPath

            mmods      <- (FilePath
 -> StateT
      (HashMap FilePath (mod, Exports))
      m
      (Maybe (FilePath, Module SrcSpanInfo)))
-> [FilePath]
-> StateT
     (HashMap FilePath (mod, Exports))
     m
     [Maybe (FilePath, Module SrcSpanInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath
-> FilePath
-> StateT
     (HashMap FilePath (mod, Exports))
     m
     (Maybe (FilePath, Module SrcSpanInfo))
forall (m :: * -> *).
(MonadIO m, MonadError AstError m) =>
FilePath -> FilePath -> m (Maybe (FilePath, Module SrcSpanInfo))
tryParseInDir FilePath
fp) [FilePath]
lp
            (pwd', m)  <- maybe
                              (failAt (filePath fp) $ "File not found in load-path: " <> showt lp)
                              (pure . (elideDot *** addMainModuleHead))
                        $ msum mmods

            rn         <- mkRenamer pwd' m
            imps       <- loadImports pwd' m

            p          <- translate fp rn imps m

            modify $ Map.insert fp p
            pure p

      where mkRenamer :: FilePath -> S.Module SrcSpanInfo -> Cache mod m Renamer
            mkRenamer :: FilePath -> Module SrcSpanInfo -> Cache mod m Renamer
mkRenamer FilePath
pwd' Module SrcSpanInfo
m = Module SrcSpanInfo -> Renamer -> Renamer
forall a. Annotation a => Module a -> Renamer -> Renamer
extendWithGlobs Module SrcSpanInfo
m (Renamer -> Renamer)
-> ([Renamer] -> Renamer) -> [Renamer] -> Renamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Renamer] -> Renamer
forall a. Monoid a => [a] -> a
mconcat ([Renamer] -> Renamer)
-> StateT (HashMap FilePath (mod, Exports)) m [Renamer]
-> Cache mod m Renamer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ImportDecl SrcSpanInfo -> Cache mod m Renamer)
-> [ImportDecl SrcSpanInfo]
-> StateT (HashMap FilePath (mod, Exports)) m [Renamer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ImportDecl SrcSpanInfo -> Cache mod m Renamer
mkRenamer' (Module SrcSpanInfo -> [ImportDecl SrcSpanInfo]
forall a. Annotation a => Module a -> [ImportDecl a]
getImps Module SrcSpanInfo
m)
                  where mkRenamer' :: ImportDecl SrcSpanInfo -> Cache mod m Renamer
                        mkRenamer' :: ImportDecl SrcSpanInfo -> Cache mod m Renamer
mkRenamer' (ImportDecl SrcSpanInfo
l (ModuleName SrcSpanInfo -> ModuleName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> ModuleName ()
m) Bool
quald Bool
_ Bool
_ Maybe FilePath
_ ((ModuleName SrcSpanInfo -> ModuleName ())
-> Maybe (ModuleName SrcSpanInfo) -> Maybe (ModuleName ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName SrcSpanInfo -> ModuleName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> Maybe (ModuleName ())
as) Maybe (ImportSpecList SrcSpanInfo)
specs) = do
                              (_, exps) <- SrcSpanInfo
-> Cache mod m (mod, Exports) -> Cache mod m (mod, Exports)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> m a -> m a
relocatingTo SrcSpanInfo
l (Cache mod m (mod, Exports) -> Cache mod m (mod, Exports))
-> Cache mod m (mod, Exports) -> Cache mod m (mod, Exports)
forall a b. (a -> b) -> a -> b
$ (FilePath
 -> Renamer
 -> mod
 -> Module SrcSpanInfo
 -> Cache mod m (mod, Exports))
-> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
forall mod (m :: * -> *).
(MonadIO m, MonadError AstError m, Monoid mod) =>
(FilePath
 -> Renamer
 -> mod
 -> Module SrcSpanInfo
 -> Cache mod m (mod, Exports))
-> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
getModuleWith FilePath
-> Renamer
-> mod
-> Module SrcSpanInfo
-> Cache mod m (mod, Exports)
translate Config
conf FilePath
pwd' (FilePath -> Cache mod m (mod, Exports))
-> FilePath -> Cache mod m (mod, Exports)
forall a b. (a -> b) -> a -> b
$ ModuleName () -> FilePath
forall a. ModuleName a -> FilePath
toFilePath ModuleName ()
m
                              fromImps m quald exps as specs

            loadImports :: Annotation a => FilePath -> S.Module a -> Cache mod m mod
            loadImports :: forall a. Annotation a => FilePath -> Module a -> Cache mod m mod
loadImports FilePath
pwd' = ([mod] -> mod)
-> StateT (HashMap FilePath (mod, Exports)) m [mod]
-> Cache mod m mod
forall a b.
(a -> b)
-> StateT (HashMap FilePath (mod, Exports)) m a
-> StateT (HashMap FilePath (mod, Exports)) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [mod] -> mod
forall a. Monoid a => [a] -> a
mconcat (StateT (HashMap FilePath (mod, Exports)) m [mod]
 -> Cache mod m mod)
-> (Module a -> StateT (HashMap FilePath (mod, Exports)) m [mod])
-> Module a
-> Cache mod m mod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportDecl a -> Cache mod m mod)
-> [ImportDecl a]
-> StateT (HashMap FilePath (mod, Exports)) m [mod]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ImportDecl a -> Cache mod m mod
forall {a}. Annotation a => ImportDecl a -> Cache mod m mod
loadImp ([ImportDecl a]
 -> StateT (HashMap FilePath (mod, Exports)) m [mod])
-> (Module a -> [ImportDecl a])
-> Module a
-> StateT (HashMap FilePath (mod, Exports)) m [mod]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module a -> [ImportDecl a]
forall a. Annotation a => Module a -> [ImportDecl a]
getImps
                  where loadImp :: ImportDecl a -> Cache mod m mod
loadImp imp :: ImportDecl a
imp@(ImportDecl a
l ModuleName a
_ Bool
_ Bool
_ Bool
_ Maybe FilePath
_ Maybe (ModuleName a)
_ Maybe (ImportSpecList a)
_) = (mod, Exports) -> mod
forall a b. (a, b) -> a
fst ((mod, Exports) -> mod)
-> Cache mod m (mod, Exports) -> Cache mod m mod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Cache mod m (mod, Exports) -> Cache mod m (mod, Exports)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> m a -> m a
relocatingTo a
l ((FilePath
 -> Renamer
 -> mod
 -> Module SrcSpanInfo
 -> Cache mod m (mod, Exports))
-> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
forall mod (m :: * -> *).
(MonadIO m, MonadError AstError m, Monoid mod) =>
(FilePath
 -> Renamer
 -> mod
 -> Module SrcSpanInfo
 -> Cache mod m (mod, Exports))
-> Config -> FilePath -> FilePath -> Cache mod m (mod, Exports)
getModuleWith FilePath
-> Renamer
-> mod
-> Module SrcSpanInfo
-> Cache mod m (mod, Exports)
translate Config
conf FilePath
pwd' (FilePath -> Cache mod m (mod, Exports))
-> FilePath -> Cache mod m (mod, Exports)
forall a b. (a -> b) -> a -> b
$ ModuleName () -> FilePath
forall a. ModuleName a -> FilePath
toFilePath (ModuleName () -> FilePath) -> ModuleName () -> FilePath
forall a b. (a -> b) -> a -> b
$ ModuleName a -> ModuleName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModuleName a -> ModuleName ()) -> ModuleName a -> ModuleName ()
forall a b. (a -> b) -> a -> b
$ ImportDecl a -> ModuleName a
forall l. ImportDecl l -> ModuleName l
importModule ImportDecl a
imp)

            elideDot :: FilePath -> FilePath
            elideDot :: FilePath -> FilePath
elideDot = \ case
                  FilePath
"." -> FilePath -> FilePath
takeDirectory FilePath
fp
                  FilePath
d   -> FilePath
d FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeDirectory FilePath
fp