{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cryptol.Project
  ( Config(..)
  , loadConfig
  , ScanStatus(..)
  , ChangeStatus(..)
  , InvalidStatus(..)
  , LoadProjectMode(..)
  , Parsed
  , loadProject
  , depMap
  ) where

import           Control.Monad                    (void)
import           Data.Foldable
import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import           Data.Set                         (Set)
import qualified Data.Set                         as Set
import           Data.Traversable
import           System.Directory
import           System.FilePath                  as FP

import           Cryptol.ModuleSystem.Base        as M
import           Cryptol.ModuleSystem.Env
import           Cryptol.ModuleSystem.Fingerprint
import           Cryptol.ModuleSystem.Monad       as M
import           Cryptol.Project.Config
import           Cryptol.Project.Cache
import           Cryptol.Project.Monad
import           Cryptol.Project.WildMatch
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position (Located(..))
import Control.Exception (try)

-- | Load a project.
-- Returns information about the modules that are part of the project.
loadProject :: LoadProjectMode -> Config -> M.ModuleM (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus, Map CacheModulePath (Maybe Bool))
loadProject :: LoadProjectMode
-> Config
-> ModuleM
     (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus,
      Map CacheModulePath (Maybe Bool))
loadProject LoadProjectMode
mode Config
cfg =
   do (Map CacheModulePath FullFingerprint
fps, Map ModulePath ScanStatus
statuses, Either ModuleError (Map CacheModulePath (Maybe Bool))
out) <- LoadProjectMode
-> Config
-> LoadM NoErr (Map CacheModulePath (Maybe Bool))
-> ModuleM
     (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus,
      Either ModuleError (Map CacheModulePath (Maybe Bool)))
forall a.
LoadProjectMode
-> Config
-> LoadM NoErr a
-> ModuleM
     (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus,
      Either ModuleError a)
runLoadM LoadProjectMode
mode Config
cfg ([String] -> LoadM NoErr ()
forall any. [String] -> LoadM any ()
loadPatterns (Config -> [String]
modules Config
cfg) LoadM NoErr ()
-> LoadM NoErr (Map CacheModulePath (Maybe Bool))
-> LoadM NoErr (Map CacheModulePath (Maybe Bool))
forall a b. LoadM NoErr a -> LoadM NoErr b -> LoadM NoErr b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LoadM NoErr (Map CacheModulePath (Maybe Bool))
forall any. LoadM any (Map CacheModulePath (Maybe Bool))
getOldDocstringResults)
      let deps :: Map ModName (Set ModName)
deps = Parsed -> Map ModName (Set ModName)
depMap [(Module PName, [(ImportSource, ModulePath)])
p | Scanned ChangeStatus
_ FullFingerprint
_ Parsed
ps <- Map ModulePath ScanStatus -> [ScanStatus]
forall k a. Map k a -> [a]
Map.elems Map ModulePath ScanStatus
statuses, (Module PName, [(ImportSource, ModulePath)])
p <- Parsed
ps]

      let untested :: ModulePath -> Bool
untested (InMem{}) = Bool
False
          untested (InFile String
f) =
            case Either ModuleError (Map CacheModulePath (Maybe Bool))
out of
              Left ModuleError
_ -> Bool
True
              Right Map CacheModulePath (Maybe Bool)
m -> CacheModulePath
-> Map CacheModulePath (Maybe Bool) -> Maybe (Maybe Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> CacheModulePath
CacheInFile String
f) Map CacheModulePath (Maybe Bool)
m Maybe (Maybe Bool) -> Maybe (Maybe Bool) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Bool -> Maybe (Maybe Bool)
forall a. a -> Maybe a
Just (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)

      let needLoad :: [ModName]
needLoad = case LoadProjectMode
mode of
            LoadProjectMode
RefreshMode  -> [Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
P.mName Module PName
m) | Scanned ChangeStatus
_ FullFingerprint
_ Parsed
ps <- Map ModulePath ScanStatus -> [ScanStatus]
forall k a. Map k a -> [a]
Map.elems Map ModulePath ScanStatus
statuses, (Module PName
m, [(ImportSource, ModulePath)]
_) <- Parsed
ps]
            LoadProjectMode
ModifiedMode -> [Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
P.mName Module PName
m) | Scanned ChangeStatus
Changed FullFingerprint
_ Parsed
ps <- Map ModulePath ScanStatus -> [ScanStatus]
forall k a. Map k a -> [a]
Map.elems Map ModulePath ScanStatus
statuses, (Module PName
m, [(ImportSource, ModulePath)]
_) <- Parsed
ps]
            LoadProjectMode
UntestedMode -> [Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
P.mName Module PName
m) | (ModulePath
k, Scanned ChangeStatus
ch FullFingerprint
_ Parsed
ps) <- Map ModulePath ScanStatus -> [(ModulePath, ScanStatus)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map ModulePath ScanStatus
statuses, ChangeStatus
ch ChangeStatus -> ChangeStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ChangeStatus
Changed Bool -> Bool -> Bool
|| ModulePath -> Bool
untested ModulePath
k,  (Module PName
m, [(ImportSource, ModulePath)]
_) <- Parsed
ps]
      let order :: [ModName]
order = Map ModName (Set ModName) -> [ModName] -> [ModName]
loadOrder Map ModName (Set ModName)
deps [ModName]
needLoad

      let modDetails :: Map ModName (Module PName, ModulePath, FullFingerprint)
modDetails = [(ModName, (Module PName, ModulePath, FullFingerprint))]
-> Map ModName (Module PName, ModulePath, FullFingerprint)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
P.mName Module PName
m), (Module PName
m, ModulePath
mp, FullFingerprint
fp)) | (ModulePath
mp, Scanned ChangeStatus
_ FullFingerprint
fp Parsed
ps) <- Map ModulePath ScanStatus -> [(ModulePath, ScanStatus)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map ModulePath ScanStatus
statuses, (Module PName
m, [(ImportSource, ModulePath)]
_) <- Parsed
ps]

      let fingerprints :: Map String Fingerprint
fingerprints = [(String, Fingerprint)] -> Map String Fingerprint
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
path, FullFingerprint -> Fingerprint
moduleFingerprint FullFingerprint
ffp) | (CacheInFile String
path, FullFingerprint
ffp) <- Map CacheModulePath FullFingerprint
-> [(CacheModulePath, FullFingerprint)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map CacheModulePath FullFingerprint
fps]

      [ModName]
-> (ModName -> ModuleT IO (TCTopEntity, FileInfo)) -> ModuleT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ModName]
order \ModName
name ->
        let (Module PName
m, ModulePath
path, FullFingerprint
fp) = Map ModName (Module PName, ModulePath, FullFingerprint)
modDetails Map ModName (Module PName, ModulePath, FullFingerprint)
-> ModName -> (Module PName, ModulePath, FullFingerprint)
forall k a. Ord k => Map k a -> k -> a
Map.! ModName
name in
        -- XXX: catch modules that don't load?
        Bool
-> Bool
-> ImportSource
-> ModulePath
-> Fingerprint
-> Map String Fingerprint
-> Module PName
-> Set ModName
-> ModuleT IO (TCTopEntity, FileInfo)
doLoadModule
          Bool
True {- eval -}
          Bool
False {- quiet -}
          (ModName -> ImportSource
FromModule ModName
name)
          ModulePath
path
          (FullFingerprint -> Fingerprint
moduleFingerprint FullFingerprint
fp)
          Map String Fingerprint
fingerprints
          Module PName
m
          (Set ModName -> ModName -> Map ModName (Set ModName) -> Set ModName
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set ModName
forall a. Monoid a => a
mempty ModName
name Map ModName (Set ModName)
deps)

      let oldResults :: Map CacheModulePath (Maybe Bool)
oldResults =
            case Either ModuleError (Map CacheModulePath (Maybe Bool))
out of
              Left{} -> Map CacheModulePath (Maybe Bool)
forall a. Monoid a => a
mempty
              Right Map CacheModulePath (Maybe Bool)
x -> Map CacheModulePath (Maybe Bool)
x
      (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus,
 Map CacheModulePath (Maybe Bool))
-> ModuleM
     (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus,
      Map CacheModulePath (Maybe Bool))
forall a. a -> ModuleT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map CacheModulePath FullFingerprint
fps, Map ModulePath ScanStatus
statuses, Map CacheModulePath (Maybe Bool)
oldResults)


--------------------------------------------------------------------------------

loadPatterns :: [String] -> LoadM any ()
loadPatterns :: forall any. [String] -> LoadM any ()
loadPatterns [String]
patterns =
 do Either ModuleError [String]
mb <- LoadM Err [String] -> LoadM any (Either ModuleError [String])
forall a any. LoadM Err a -> LoadM any (Either ModuleError a)
tryLoadM (IO [String] -> LoadM Err [String]
forall a. IO a -> LoadM Err a
doIO (([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
flatten ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO [[String]]
listDirectoryRecursive []))
    case Either ModuleError [String]
mb of
      Left{} -> () -> LoadM any ()
forall a. a -> LoadM any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right [String]
files ->
       do let files' :: [String]
files' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
`wildmatch` String
x) [String]
patterns) [String]
files
          [String] -> (String -> LoadM any ()) -> LoadM any ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
files' String -> LoadM any ()
forall any. String -> LoadM any ()
scanPath

-- | Process all .cry files in the given path.
scanPath :: FilePath -> LoadM any ()
scanPath :: forall any. String -> LoadM any ()
scanPath String
path =
  LoadM Err Bool -> LoadM any (Either ModuleError Bool)
forall a any. LoadM Err a -> LoadM any (Either ModuleError a)
tryLoadM (IO Bool -> LoadM Err Bool
forall a. IO a -> LoadM Err a
doIO (String -> IO Bool
doesDirectoryExist String
path)) LoadM any (Either ModuleError Bool)
-> (Either ModuleError Bool -> LoadM any ()) -> LoadM any ()
forall a b. LoadM any a -> (a -> LoadM any b) -> LoadM any b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \case
    Left {} -> () -> LoadM any ()
forall a. a -> LoadM any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    Right Bool
True ->
      LoadM Err [String] -> LoadM any (Either ModuleError [String])
forall a any. LoadM Err a -> LoadM any (Either ModuleError a)
tryLoadM (IO [String] -> LoadM Err [String]
forall a. IO a -> LoadM Err a
doIO (String -> IO [String]
listDirectory String
path)) LoadM any (Either ModuleError [String])
-> (Either ModuleError [String] -> LoadM any ()) -> LoadM any ()
forall a b. LoadM any a -> (a -> LoadM any b) -> LoadM any b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
           Left {} -> () -> LoadM any ()
forall a. a -> LoadM any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           Right [String]
entries ->
             [String] -> (String -> LoadM any ()) -> LoadM any ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
entries \String
entry -> String -> LoadM any ()
forall any. String -> LoadM any ()
scanPath (String
path String -> String -> String
FP.</> String
entry)

    Right Bool
False ->
      -- XXX: This should probably handle other extenions
      -- (literate Cryptol)
      case String -> String
takeExtension String
path of
        String
".cry" -> LoadM any (Either ModuleError ScanStatus) -> LoadM any ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LoadM Err ScanStatus -> LoadM any (Either ModuleError ScanStatus)
forall a any. LoadM Err a -> LoadM any (Either ModuleError a)
tryLoadM (String -> LoadM Err ScanStatus
scanFromPath String
path))
                  -- XXX: failure: file disappeared.
        String
_      -> () -> LoadM any ()
forall a. a -> LoadM any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Process a particular file path.
-- Fails if we can't find the module at this path.
scanFromPath :: FilePath -> LoadM Err ScanStatus
scanFromPath :: String -> LoadM Err ScanStatus
scanFromPath String
fpath =
  (forall a. ModuleM a -> ModuleM a)
-> LoadM Err ScanStatus -> LoadM Err ScanStatus
forall any b.
(forall a. ModuleM a -> ModuleM a) -> LoadM any b -> LoadM Err b
liftCallback ([String] -> ModuleM a -> ModuleM a
forall a. [String] -> ModuleM a -> ModuleM a
withPrependedSearchPath [String -> String
takeDirectory String
fpath])
  do String
foundFPath <- ModuleM String -> LoadM Err String
forall a. ModuleM a -> LoadM Err a
doModule (String -> ModuleM String
M.findFile String
fpath)
     ModulePath
mpath      <- IO ModulePath -> LoadM Err ModulePath
forall a. IO a -> LoadM Err a
doIO (String -> ModulePath
InFile (String -> ModulePath) -> IO String -> IO ModulePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath String
foundFPath)
     ModulePath -> LoadM Err ScanStatus
forall any. ModulePath -> LoadM any ScanStatus
scan ModulePath
mpath


-- | Process the given module, and return information about what happened.
-- Also, saves the status of the module path.
scan :: ModulePath -> LoadM any ScanStatus
scan :: forall any. ModulePath -> LoadM any ScanStatus
scan ModulePath
mpath =

  LoadM Err ScanStatus -> LoadM any ScanStatus
forall {any}. LoadM Err ScanStatus -> LoadM any ScanStatus
tryIt (LoadM Err ScanStatus -> LoadM any ScanStatus)
-> LoadM Err ScanStatus -> LoadM any ScanStatus
forall a b. (a -> b) -> a -> b
$
  do Maybe ScanStatus
mbStat <- ModulePath -> LoadM Err (Maybe ScanStatus)
forall any. ModulePath -> LoadM any (Maybe ScanStatus)
getStatus ModulePath
mpath
     case Maybe ScanStatus
mbStat of
       Just ScanStatus
status -> ScanStatus -> LoadM Err ScanStatus
forall a. a -> LoadM Err a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScanStatus
status

       Maybe ScanStatus
Nothing ->
         do (FullFingerprint
newFp,Parsed
parsed) <- ModulePath -> LoadM Err (FullFingerprint, Parsed)
doParse ModulePath
mpath
            Maybe FullFingerprint
mbOldFP <- ModulePath -> LoadM Err (Maybe FullFingerprint)
forall any. ModulePath -> LoadM any (Maybe FullFingerprint)
getCachedFingerprint ModulePath
mpath
            let needLoad :: Bool
needLoad = Maybe FullFingerprint
mbOldFP Maybe FullFingerprint -> Maybe FullFingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= FullFingerprint -> Maybe FullFingerprint
forall a. a -> Maybe a
Just FullFingerprint
newFp
            let deps :: [(ImportSource, ModulePath)]
deps     = [ (ImportSource, ModulePath)
dep
                           | (Module PName
_,[(ImportSource, ModulePath)]
ds) <- Parsed
parsed
                           , dep :: (ImportSource, ModulePath)
dep@(ImportSource
_,ModulePath
otherPath) <- [(ImportSource, ModulePath)]
ds
                           , ModulePath
mpath ModulePath -> ModulePath -> Bool
forall a. Eq a => a -> a -> Bool
/= ModulePath
otherPath
                           ]
            Either (ImportSource, ModulePath) Bool
mb <- Bool
-> [(ImportSource, ModulePath)]
-> LoadM Err (Either (ImportSource, ModulePath) Bool)
forall err.
Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
checkDeps Bool
False [(ImportSource, ModulePath)]
deps
            case Either (ImportSource, ModulePath) Bool
mb of
              Left (ImportSource
a,ModulePath
b) -> ModulePath -> ScanStatus -> LoadM Err ScanStatus
forall any. ModulePath -> ScanStatus -> LoadM any ScanStatus
addScanned ModulePath
mpath (InvalidStatus -> ScanStatus
Invalid (ImportSource -> ModulePath -> InvalidStatus
InvalidDep ImportSource
a ModulePath
b))
              Right Bool
depChanges ->
                do let ch :: ChangeStatus
ch = if Bool
needLoad Bool -> Bool -> Bool
|| Bool
depChanges
                            then ChangeStatus
Changed else ChangeStatus
Unchanged
                   ModulePath -> ScanStatus -> LoadM Err ScanStatus
forall any. ModulePath -> ScanStatus -> LoadM any ScanStatus
addScanned ModulePath
mpath (ChangeStatus -> FullFingerprint -> Parsed -> ScanStatus
Scanned ChangeStatus
ch FullFingerprint
newFp Parsed
parsed)
  where
  tryIt :: LoadM Err ScanStatus -> LoadM any ScanStatus
tryIt LoadM Err ScanStatus
m =
    do Either ModuleError ScanStatus
mb <- LoadM Err ScanStatus -> LoadM any (Either ModuleError ScanStatus)
forall a any. LoadM Err a -> LoadM any (Either ModuleError a)
tryLoadM LoadM Err ScanStatus
m
       case Either ModuleError ScanStatus
mb of
         Left ModuleError
err -> ModulePath -> ScanStatus -> LoadM any ScanStatus
forall any. ModulePath -> ScanStatus -> LoadM any ScanStatus
addScanned ModulePath
mpath (InvalidStatus -> ScanStatus
Invalid (ModuleError -> InvalidStatus
InvalidModule ModuleError
err))
         Right ScanStatus
a  -> ScanStatus -> LoadM any ScanStatus
forall a. a -> LoadM any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScanStatus
a


-- | Parse a module.
doParse :: ModulePath -> LoadM Err (FullFingerprint, Parsed)
doParse :: ModulePath -> LoadM Err (FullFingerprint, Parsed)
doParse ModulePath
mpath =
  do String
lab <- ModulePath -> LoadM Err String
forall any. ModulePath -> LoadM any String
getModulePathLabel ModulePath
mpath
     String -> LoadM Err ()
forall any. String -> LoadM any ()
lPutStrLn (String
"Scanning " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lab)

     ([(Module PName, [ImportSource])]
parsed, FullFingerprint
newFp) <-
        ModuleM ([(Module PName, [ImportSource])], FullFingerprint)
-> LoadM Err ([(Module PName, [ImportSource])], FullFingerprint)
forall a. ModuleM a -> LoadM Err a
doModule
        do (FileInfo
fi, [(Module PName, [ImportSource])]
parsed) <- ModulePath -> ModuleM (FileInfo, [(Module PName, [ImportSource])])
parseWithDeps ModulePath
mpath
           Set Fingerprint
foreignFps   <- Map String Bool -> ModuleM (Set Fingerprint)
getForeignFps (FileInfo -> Map String Bool
fiForeignDeps FileInfo
fi)
           ([(Module PName, [ImportSource])], FullFingerprint)
-> ModuleM ([(Module PName, [ImportSource])], FullFingerprint)
forall a. a -> ModuleT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [(Module PName, [ImportSource])]
parsed
                , FullFingerprint
                    { moduleFingerprint :: Fingerprint
moduleFingerprint   = FileInfo -> Fingerprint
fiFingerprint FileInfo
fi
                    , includeFingerprints :: Map String Fingerprint
includeFingerprints = FileInfo -> Map String Fingerprint
fiIncludeDeps FileInfo
fi
                    , foreignFingerprints :: Set Fingerprint
foreignFingerprints = Set Fingerprint
foreignFps
                    }
                 )
     ModulePath -> FullFingerprint -> LoadM Err ()
forall any. ModulePath -> FullFingerprint -> LoadM any ()
addFingerprint ModulePath
mpath FullFingerprint
newFp
     Parsed
ps <- [(Module PName, [ImportSource])]
-> ((Module PName, [ImportSource])
    -> LoadM Err (Module PName, [(ImportSource, ModulePath)]))
-> LoadM Err Parsed
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Module PName, [ImportSource])]
parsed \(Module PName
m,[ImportSource]
ds) ->
             do [ModulePath]
paths <- (ImportSource -> LoadM Err ModulePath)
-> [ImportSource] -> LoadM Err [ModulePath]
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 ImportSource -> LoadM Err ModulePath
findModule' [ImportSource]
ds
                (Module PName, [(ImportSource, ModulePath)])
-> LoadM Err (Module PName, [(ImportSource, ModulePath)])
forall a. a -> LoadM Err a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module PName
m, [ImportSource] -> [ModulePath] -> [(ImportSource, ModulePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ImportSource]
ds [ModulePath]
paths)
     (FullFingerprint, Parsed) -> LoadM Err (FullFingerprint, Parsed)
forall a. a -> LoadM Err a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FullFingerprint
newFp, Parsed
ps)

-- | Get the fingerprints for external libraries.
getForeignFps :: Map FilePath Bool -> ModuleM (Set Fingerprint)
getForeignFps :: Map String Bool -> ModuleM (Set Fingerprint)
getForeignFps Map String Bool
fsrcPaths =
  [Fingerprint] -> Set Fingerprint
forall a. Ord a => [a] -> Set a
Set.fromList ([Fingerprint] -> Set Fingerprint)
-> ModuleT IO [Fingerprint] -> ModuleM (Set Fingerprint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    let foundFiles :: [String]
foundFiles = Map String Bool -> [String]
forall k a. Map k a -> [k]
Map.keys ((Bool -> Bool) -> Map String Bool -> Map String Bool
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Bool -> Bool
forall a. a -> a
id Map String Bool
fsrcPaths) in
    [String]
-> (String -> ModuleT IO Fingerprint) -> ModuleT IO [Fingerprint]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
foundFiles \String
fsrcPath ->
      IO (Either IOError Fingerprint)
-> ModuleT IO (Either IOError Fingerprint)
forall (m :: * -> *) a. BaseM m IO => IO a -> ModuleT m a
M.io (String -> IO (Either IOError Fingerprint)
fingerprintFile String
fsrcPath) ModuleT IO (Either IOError Fingerprint)
-> (Either IOError Fingerprint -> ModuleT IO Fingerprint)
-> ModuleT IO Fingerprint
forall a b. ModuleT IO a -> (a -> ModuleT IO b) -> ModuleT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        \case
          Left IOError
ioe -> String -> IOError -> ModuleT IO Fingerprint
forall a. String -> IOError -> ModuleM a
otherIOError String
fsrcPath IOError
ioe
          Right Fingerprint
fp -> Fingerprint -> ModuleT IO Fingerprint
forall a. a -> ModuleT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fingerprint
fp

-- | Scan the dependencies of a module.
checkDeps ::
  Bool {- ^ Should we load the dependencies -} ->
  [(ImportSource,ModulePath)] {- ^ The dependencies -} ->
  LoadM err (Either (ImportSource,ModulePath) Bool)
  -- ^ Returns `Left bad_dep` if one of the dependencies fails to load.
  -- Returns `Right changes` if all dependencies were validated correctly.
  -- The boolean flag `changes` indicates if any of the dependencies contain
  -- changes and so we should also load the main module.
checkDeps :: forall err.
Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
checkDeps Bool
shouldLoad [(ImportSource, ModulePath)]
ds =
  case [(ImportSource, ModulePath)]
ds of
    [] -> Either (ImportSource, ModulePath) Bool
-> LoadM err (Either (ImportSource, ModulePath) Bool)
forall a. a -> LoadM err a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either (ImportSource, ModulePath) Bool
forall a b. b -> Either a b
Right Bool
shouldLoad)
    (ImportSource
imp, ModulePath
mpath) : [(ImportSource, ModulePath)]
more ->
      do ScanStatus
status <- ModulePath -> LoadM err ScanStatus
forall any. ModulePath -> LoadM any ScanStatus
scan ModulePath
mpath
         case ScanStatus
status of
           Invalid {} -> Either (ImportSource, ModulePath) Bool
-> LoadM err (Either (ImportSource, ModulePath) Bool)
forall a. a -> LoadM err a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ImportSource, ModulePath)
-> Either (ImportSource, ModulePath) Bool
forall a b. a -> Either a b
Left (ImportSource
imp,ModulePath
mpath))
           Scanned ChangeStatus
ch FullFingerprint
_ Parsed
_ ->
             case ChangeStatus
ch of
               ChangeStatus
Changed   -> Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
forall err.
Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
checkDeps Bool
True [(ImportSource, ModulePath)]
more
               ChangeStatus
Unchanged -> Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
forall err.
Bool
-> [(ImportSource, ModulePath)]
-> LoadM err (Either (ImportSource, ModulePath) Bool)
checkDeps Bool
shouldLoad [(ImportSource, ModulePath)]
more


depMap :: Parsed -> Map P.ModName (Set P.ModName)
depMap :: Parsed -> Map ModName (Set ModName)
depMap Parsed
xs = [(ModName, Set ModName)] -> Map ModName (Set ModName)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
P.mName Module PName
k), [ModName] -> Set ModName
forall a. Ord a => [a] -> Set a
Set.fromList [ImportSource -> ModName
importedModule ImportSource
i | (ImportSource
i, ModulePath
_) <- [(ImportSource, ModulePath)]
v]) | (Module PName
k, [(ImportSource, ModulePath)]
v) <- Parsed
xs]

loadOrder :: Map P.ModName (Set P.ModName) -> [P.ModName] -> [P.ModName]
loadOrder :: Map ModName (Set ModName) -> [ModName] -> [ModName]
loadOrder Map ModName (Set ModName)
deps [ModName]
roots0 = (Set ModName, [ModName] -> [ModName]) -> [ModName] -> [ModName]
forall a b. (a, b) -> b
snd (Set ModName -> [ModName] -> (Set ModName, [ModName] -> [ModName])
go Set ModName
forall a. Set a
Set.empty [ModName]
roots0) []
  where
    go :: Set ModName -> [ModName] -> (Set ModName, [ModName] -> [ModName])
go Set ModName
seen [ModName]
mms =
      case [ModName]
mms of
        [] -> (Set ModName
seen, [ModName] -> [ModName]
forall a. a -> a
id)
        ModName
m : [ModName]
ms
          | ModName -> Set ModName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ModName
m Set ModName
seen -> Set ModName -> [ModName] -> (Set ModName, [ModName] -> [ModName])
go Set ModName
seen [ModName]
ms
          | (Set ModName
seen1, [ModName] -> [ModName]
out1) <- Set ModName -> [ModName] -> (Set ModName, [ModName] -> [ModName])
go (ModName -> Set ModName -> Set ModName
forall a. Ord a => a -> Set a -> Set a
Set.insert ModName
m Set ModName
seen) (Set ModName -> [ModName]
forall a. Set a -> [a]
Set.toList (Set ModName -> ModName -> Map ModName (Set ModName) -> Set ModName
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set ModName
forall a. Monoid a => a
mempty ModName
m Map ModName (Set ModName)
deps))
          , (Set ModName
seen2, [ModName] -> [ModName]
out2) <- Set ModName -> [ModName] -> (Set ModName, [ModName] -> [ModName])
go Set ModName
seen1 [ModName]
ms
          -> (Set ModName
seen2, [ModName] -> [ModName]
out1 ([ModName] -> [ModName])
-> ([ModName] -> [ModName]) -> [ModName] -> [ModName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModName
mModName -> [ModName] -> [ModName]
forall a. a -> [a] -> [a]
:) ([ModName] -> [ModName])
-> ([ModName] -> [ModName]) -> [ModName] -> [ModName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModName] -> [ModName]
out2)

-- Similar to listDirectory except directories are expanded
-- when possible instead of returned in the list
listDirectoryRecursive :: [FilePath] -> IO [[FilePath]]
listDirectoryRecursive :: [String] -> IO [[String]]
listDirectoryRecursive [String]
d =
 do [String]
localEntries <- String -> IO [String]
listDirectory ([String] -> String
flatten [String]
d)
    [[[String]]] -> [[String]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[String]]] -> [[String]]) -> IO [[[String]]] -> IO [[String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> (String -> IO [[String]]) -> IO [[[String]]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
localEntries \String
x ->
     do let x' :: [String]
x' = [String]
d [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
x]
        Either IOError [[String]]
mb <- IO [[String]] -> IO (Either IOError [[String]])
forall e a. Exception e => IO a -> IO (Either e a)
try ([String] -> IO [[String]]
listDirectoryRecursive [String]
x')
        case Either IOError [[String]]
mb of
          Left (IOError
_ :: IOError) -> [[String]] -> IO [[String]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[String]
x']
          Right [[String]]
xs -> [[String]] -> IO [[String]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[String]]
xs

flatten :: [String] -> String
flatten :: [String] -> String
flatten [] = String
"."
flatten [String]
xs = (String -> String -> String) -> [String] -> String
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\String
x String
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y) [String]
xs