serokell/importify

{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE QuasiQuotes    #-}
{-# LANGUAGE TypeOperators  #-}

-- | This module contains common utilities for working with importify cache.

module Importify.Path
       ( -- * Predefined directories
         importifyDir
       , importifyPath
       , extensionsFile
       , extensionsPath
       , modulesFile
       , modulesPath
       , symbolsDir
       , symbolsPath
       , testDataPath

         -- * Utility functions to work with files and directories
       , decodeFileOrMempty
       , doInsideDir
       , findCabalFile
       , lookupToRoot
       ) where

import Universum

import Data.Aeson (FromJSON, eitherDecodeStrict)
import Fmt ((+|), (+||), (|+), (||+))
import Path (Abs, Dir, File, Path, Rel, dirname, fromAbsDir, fromAbsFile, fromRelDir, fromRelFile,
             parent, reldir, relfile, toFilePath, (</>))
import Path.IO (doesFileExist, ensureDir, getCurrentDir, listDir)
import System.FilePath (takeExtension)
import Turtle (cd, pwd)

import Extended.System.Wlog (printNotice, printWarning)

import qualified Data.ByteString as BS (readFile)

importifyPath :: Path Rel Dir
importifyPath = [reldir|.importify/|]

-- | Path to file that stores mapping from module names to their packages.
modulesPath :: Path Rel File
modulesPath = [relfile|modules|]

symbolsPath :: Path Rel Dir
symbolsPath = [reldir|symbols/|]

-- | Path to golden tests.
testDataPath :: Path Rel Dir
testDataPath = [reldir|test/test-data/|]

-- | Path to JSON-encoded Map from target to its list of default extensions.
extensionsPath :: Path Rel File
extensionsPath = [relfile|extensions|]

importifyDir, extensionsFile, modulesFile, symbolsDir :: FilePath
importifyDir   = fromRelDir  importifyPath
extensionsFile = fromRelFile extensionsPath
modulesFile    = fromRelFile modulesPath
symbolsDir     = fromRelDir  symbolsPath

-- | Returns relative path to cabal file under given directory.
findCabalFile :: MonadIO m => Path Abs Dir -> m $ Maybe $ Path Abs File
findCabalFile projectPath = do
    (_, projectFiles) <- listDir projectPath
    return $ find isCabalFile projectFiles

isCabalFile :: Path Abs File -> Bool
isCabalFile = (== ".cabal") . takeExtension . fromAbsFile

-- | Create given directory and perform given action inside it.
doInsideDir :: (MonadIO m, MonadMask m) => Path Abs Dir -> m a -> m a
doInsideDir dir action = do
    thisDirectory <- pwd
    bracket_ (do ensureDir dir
                 cd $ fromString $ fromAbsDir dir)
             (cd thisDirectory)
             action

-- | Walk up till root while unpure predicate is 'False'. Returns
-- absolute path to directory where predicate is 'True' and suffix of
-- current directory prepended to given file.
lookupToRoot :: (Path Abs Dir -> IO Bool)
             -> Path Rel File
             -> IO (Maybe (Path Abs Dir, Path Rel File))
lookupToRoot predicate relativeFile = do
    currentDir <- getCurrentDir
    pathLoop currentDir relativeFile
  where
    pathLoop :: Path Abs Dir -> Path Rel File -> IO (Maybe (Path Abs Dir, Path Rel File))
    pathLoop directory file = do
        predicateIsTrue <- predicate directory
        if predicateIsTrue then
            return $ Just (directory, file)
        else if parent directory == directory then  -- fixpoint reached
            return Nothing
        else do
            let parentDir = parent  directory
            let   thisDir = dirname directory
            pathLoop parentDir (thisDir </> file)

-- | Tries to read file and then 'decode' it. If either of two phases
-- fails then 'mempty' returned and warning is printed to console.
decodeFileOrMempty :: forall t m f b .
                      (FromJSON t, Monoid m, MonadIO f)
                   => Path b File  -- ^ Path to json data
                   -> (t -> f m)   -- ^ Action from decoded value
                   -> f m
decodeFileOrMempty file onDecodedContent = do
    isFileExist <- doesFileExist file

    if isFileExist then
        eitherDecodeStrict <$> liftIO (BS.readFile $ toFilePath file) >>= \case
            Right value -> onDecodedContent value
            Left msg    -> do
              let warning = "File '"+||file||+"' decoded incorrectly because of: "+|msg|+""
              mempty <$ printWarning warning
    else do
        let msg = "File '"+||file||+
                  "' doesn't exist: caching first time or previous caching failed"
        mempty <$ printNotice msg