GlobalCache.hs

{-# LANGUAGE ApplicativeDo #-}

module Descript.Build.Cache.GlobalCache
  ( GlobalCache
  , CacheDelegate (..)
  , newGlobalCache
  , addFile
  , delFile
  , changeFile
  , refactorFile
  ) where

import Descript.Build.Cache.FileCache
import Descript.Build.Cache.PhaseCache
import Descript.Build.Cache.Error
import Descript.Build.Read
import qualified Descript.BasicInj as BasicInj
import qualified Descript.Sugar as Sugar
import qualified Descript.Free as Free
import qualified Descript.Lex as Lex
import Descript.Misc
import Core.Data.Functor
import Data.Text (Text)
import qualified Data.HashTable.IO as HashTable
import Control.Monad
import Control.Monad.IO.Class
import System.FilePath

type HashTable k v = HashTable.BasicHashTable k v

-- | Contains cached ASTs, which are keyed by file paths or URIs
-- (presumably to the file on disk where thhey're located).
-- This caches multiple ASTs, and it can handle as many as needed - a
-- directory, a workspace, or even multiple workspaces.
newtype GlobalCache = GlobalCache (HashTable FilePath FileCache)

-- | Gets called whenever a cache is updated.
data CacheDelegate io
  = CacheDelegate
  { onUpdateFile :: FileUpdate -> FileCache -> io ()
  , onWarning :: CacheWarning -> io () -> io ()
  , onError :: CacheError -> io ()
  }

newGlobalCache :: (MonadIO io) => io GlobalCache
newGlobalCache = liftIO $ GlobalCache <$> HashTable.new

-- | Note: if a file already existed at the path, replaces it,
-- invalidating its cached AST.
addFile :: (MonadIO io)
        => CacheDelegate io
        -> FilePath
        -> FileVersion
        -> Text
        -> GlobalCache
        -> io ()
addFile delegate path nver text (GlobalCache files) = do
  let update = UpdateText text Nothing
  file <- updateFileCascade delegate path update $ newFileCache nver
  liftIO $ HashTable.insert files path file

delFile :: (MonadIO io) => FilePath -> GlobalCache -> io ()
delFile path (GlobalCache files) = liftIO $ HashTable.delete files path

-- | Applies the update, then applies cascading updates.
-- Notifies the delegate of every update, including this one.
updateFile :: (MonadIO io)
           => CacheDelegate io
           -> FilePath
           -> FileVersion
           -> FileUpdate
           -> GlobalCache
           -> io ()
updateFile delegate path nver update (GlobalCache files) = do
  oldOpt <- liftIO $ HashTable.lookup files path
  case oldOpt of
    Nothing -> onError delegate CacheFileNotFound
    Just old -> do
      new <- updateFileCascade delegate path update $ dateFileCache nver old
      liftIO $ HashTable.insert files path new

-- | Applies the given update, then applies cascading updates.
-- Notifies the delegate of every update, including this one.
updateFileCascade :: (MonadIO io)
                  => CacheDelegate io
                  -> FilePath
                  -> FileUpdate
                  -> FileCache
                  -> io FileCache
updateFileCascade delegate path update old = do
  let new = updateFileCache update old
  onUpdateFile delegate update new
  cascadeUpdateFile delegate path update new

-- | Updates other parts of the file to match the part which was
-- updated. For example, if the text was updated, will update ASTs.
-- If an AST was updated, will update the text and other ASTs.
-- The delegate will be notified of each update.
cascadeUpdateFile :: (MonadIO io)
                  => CacheDelegate io
                  -> FilePath
                  -> FileUpdate
                  -> FileCache
                  -> io FileCache
cascadeUpdateFile delegate path update
    = cascadeUpdateFileFwd delegate path update
  <=< cascadeUpdateFileBwd delegate path update

-- | Updates more complex ASTs (text -> lex -> free -> ...).
-- Assumes simpler ASTs are updated, so they can be re-used.
cascadeUpdateFileFwd :: (MonadIO io)
                     => CacheDelegate io
                     -> FilePath
                     -> FileUpdate
                     -> FileCache
                     -> io FileCache
cascadeUpdateFileFwd delegate path update
  = cascadeUpdateFileFwdFull delegate path update
  . prepareFileCache update

cascadeUpdateFileFwdFull :: (MonadIO io)
                         => CacheDelegate io
                         -> FilePath
                         -> FileUpdate
                         -> FileCache
                         -> io FileCache
cascadeUpdateFileFwdFull delegate path (UpdateText new _) x
  | phaseCacheUpdated $ srcLex x = pure x
  | otherwise
  = case Lex.parse file of
         Failure err -> x <$ onError delegate (CacheParseError x err)
         Success next -> updateFileCascadeFwd delegate path update x
           where update = UpdateLex $ parsedSrcAnn <<$>> next
  where file = mkSFile path new
cascadeUpdateFileFwdFull delegate path (UpdateLex _) x
  | phaseCacheUpdated $ srcFree x = pure x
  | otherwise
  = case Free.parse file new of
         Failure err -> x <$ onError delegate (CacheParseError x err)
         Success next -> updateFileCascadeFwd delegate path update x
           where update = UpdateFree $ parsedSrcAnn <<$>> next
  where file = mkSFile path $ forceGetPhaseCache $ srcText x
        new = forceGetPhaseCache $ srcLex x -- Doesn't use 'SrcAnn'
cascadeUpdateFileFwdFull delegate path (UpdateFree _) x
  | phaseCacheUpdated $ srcSugar x = pure x
  | otherwise
  = case Sugar.parse file new of
         Failure err -> x <$ onError delegate (CacheParseError x err)
         Success next -> updateFileCascadeFwd delegate path update x
           where update = UpdateSugar $ parsedSrcAnn <$> next
  where file = mkSFile path $ forceGetPhaseCache $ srcText x
        new = forceGetPhaseCache $ srcFree x -- Doesn't use 'SrcAnn'
cascadeUpdateFileFwdFull delegate path (UpdateSugar _) x
  | phaseCacheUpdated $ srcBasicInj x = pure x
  | otherwise = do
    let new = forceGetPhaseCache $ srcSugar x -- Doesn't use 'SrcAnn'
        new' = parsedSrcAnn <$> new
        rsvr = defaultResolver $ takeDirectory path
    ddep <- liftIO $ runDirtyT $ BasicInj.extraModule rsvr $ Sugar.sourceImportCtx new'
    let dep = dirtyVal ddep
        nextSrc = Sugar.refine dep new'
        next = Depd ddep nextSrc
        update = UpdateBasicInj next
    updateFileCascadeFwd delegate path update x
cascadeUpdateFileFwdFull _ _ (UpdateBasicInj _) x = pure x

-- | Updates simpler ASTs (... -> free -> lex -> text).
-- Doesn't assume more complex ASTs are updated.
cascadeUpdateFileBwd :: (MonadIO io)
                     => CacheDelegate io
                     -> FilePath
                     -> FileUpdate
                     -> FileCache
                     -> io FileCache
cascadeUpdateFileBwd _ _ (UpdateText _ _) x = pure x
cascadeUpdateFileBwd delegate path (UpdateLex new) x
  = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x
  where prev
          = case phaseCached $ srcText x of
                 Nothing -> pprintF new
                 Just cachedPrev -> patch `apPatch` cachedPrev
        patch = ppatchF new
cascadeUpdateFileBwd delegate path (UpdateFree new) x
  = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x
  where prev
          = case phaseCached $ srcText x of
                 Nothing -> pprintF new
                 Just cachedPrev -> patch `apPatch` cachedPrev
        patch = ppatchF new
cascadeUpdateFileBwd delegate path (UpdateSugar new) x
  = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x
  where prev
          = case phaseCached $ srcText x of
                 Nothing -> pprint new
                 Just cachedPrev -> patch `apPatch` cachedPrev
        patch = ppatch new
cascadeUpdateFileBwd delegate path (UpdateBasicInj new) x
  = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x
  where prev
          = case phaseCached $ srcText x of
                 Nothing -> pprint newSrc
                 Just cachedPrev -> patch `apPatch` cachedPrev
        patch = ppatch newSrc
        newSrc = depdVal new

-- | Applies the given update, then applies forward cascading updates.
-- Notifies the delegate of all updates before they're applied.
updateFileCascadeFwd :: (MonadIO io)
                     => CacheDelegate io
                     -> FilePath
                     -> FileUpdate
                     -> FileCache
                     -> io FileCache
updateFileCascadeFwd delegate path update old = do
  let new = updateFileCache update old
  onUpdateFile delegate update new
  cascadeUpdateFileFwd delegate path update new

-- | Updates other parts of the file based on an individual change.
-- If the change is a patch, Assumes the cached file already has
-- previously updated text (otherwise it couldn't be patched).
changeFile :: (MonadIO io)
           => CacheDelegate io
           -> FilePath
           -> FileVersion
           -> Change
           -> GlobalCache
           -> io ()
changeFile delegate path nver (Left newText)
  = replaceFile delegate path nver newText
changeFile delegate path nver (Right patch)
  = patchFile delegate path nver patch

replaceFile :: (MonadIO io)
            => CacheDelegate io
            -> FilePath
            -> FileVersion
            -> Text
            -> GlobalCache
            -> io ()
replaceFile delegate path nver new
  = updateFile delegate path nver $ UpdateText new Nothing

-- | Updates other parts of the file based on the given part being
-- updated. Assumes the cached file already has previously updated text.
patchFile :: (MonadIO io)
          => CacheDelegate io
          -> FilePath
          -> FileVersion
          -> Patch
          -> GlobalCache
          -> io ()
patchFile delegate path nver patch (GlobalCache files) = do
  oldOpt <- liftIO $ HashTable.lookup files path
  case oldOpt of
    Nothing -> onError delegate CacheFileNotFound
    Just old
      | not $ phaseCacheUpdated $ srcText old ->
          onError delegate CachePatchBeforeText
      | otherwise -> do
        let oldText = forceGetPhaseCache $ srcText old
            newText = patch `apPatch` oldText
            update = UpdateText newText $ Just patch
        new <- updateFileCascade delegate path update $ dateFileCache nver old
        liftIO $ HashTable.insert files path new

-- | Applies the refactor, then updates other ASTs.
refactorFile :: (MonadIO io)
             => CacheDelegate io
             -> FilePath
             -> RefactorFunc BasicInj.Source
             -> GlobalCache
             -> io ()
refactorFile delegate path refactor (GlobalCache files) = do
  oldOpt <- liftIO $ HashTable.lookup files path
  case oldOpt of
    Nothing -> onError delegate CacheFileNotFound
    Just old
      | not $ phaseCacheUpdated $ srcBasicInj old ->
          onError delegate CacheRefactorBeforeParse
      | otherwise -> do
        let Depd ddep oldBasicInjSrc
              = mapDirtyDepdAnn parsedSrcAnn
              $ forceGetPhaseCache
              $ srcBasicInj old
            Dirty warns res = runDirtyRes $ refactor oldBasicInjSrc
        case res of
          Failure err -> onError delegate $ CacheRefactorError old err
          Success newBasicInjSrc
            | not $ null warns -> onWarning delegate warning continue
            | otherwise -> continue
            where continue = do
                    onUpdateFile delegate update old'
                    new <- updateFileCascade delegate path update old'
                    liftIO $ HashTable.insert files path new
                  update = UpdateBasicInj newBasicInj
                  warning = CacheRefactorWarning old warns
                  newBasicInj = Depd ddep newBasicInjSrc
                  old' = dateFileCache (fileVersion old) old