{-# Language OverloadedStrings, BlockArguments #-}
module Cryptol.Project.Cache where

import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import qualified Data.Set                         as Set
import qualified Data.Text.IO                     as Text
import           Data.Set                         (Set)
import           System.Directory
import           System.FilePath                  as FP
import           System.IO.Error
import qualified Toml
import qualified Toml.Schema                      as Toml
import           Cryptol.ModuleSystem.Fingerprint ( Fingerprint )
import           Cryptol.ModuleSystem.Env

-- | The load cache. This is what persists across invocations.
newtype LoadCache = LoadCache
  { LoadCache -> Map CacheModulePath CacheEntry
cacheModules :: Map CacheModulePath CacheEntry
  }
  deriving (Int -> LoadCache -> ShowS
[LoadCache] -> ShowS
LoadCache -> String
(Int -> LoadCache -> ShowS)
-> (LoadCache -> String)
-> ([LoadCache] -> ShowS)
-> Show LoadCache
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadCache -> ShowS
showsPrec :: Int -> LoadCache -> ShowS
$cshow :: LoadCache -> String
show :: LoadCache -> String
$cshowList :: [LoadCache] -> ShowS
showList :: [LoadCache] -> ShowS
Show, ReadPrec [LoadCache]
ReadPrec LoadCache
Int -> ReadS LoadCache
ReadS [LoadCache]
(Int -> ReadS LoadCache)
-> ReadS [LoadCache]
-> ReadPrec LoadCache
-> ReadPrec [LoadCache]
-> Read LoadCache
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS LoadCache
readsPrec :: Int -> ReadS LoadCache
$creadList :: ReadS [LoadCache]
readList :: ReadS [LoadCache]
$creadPrec :: ReadPrec LoadCache
readPrec :: ReadPrec LoadCache
$creadListPrec :: ReadPrec [LoadCache]
readListPrec :: ReadPrec [LoadCache]
Read)

toCacheModulePath :: ModulePath -> CacheModulePath
toCacheModulePath :: ModulePath -> CacheModulePath
toCacheModulePath ModulePath
mpath =
  case ModulePath
mpath of
    InMem String
x ByteString
_ -> String -> CacheModulePath
CacheInMem String
x
    InFile String
x -> String -> CacheModulePath
CacheInFile String
x

data CacheModulePath
  = CacheInMem String -- ^ module name
  | CacheInFile FilePath -- ^ absolute file path
  deriving (Int -> CacheModulePath -> ShowS
[CacheModulePath] -> ShowS
CacheModulePath -> String
(Int -> CacheModulePath -> ShowS)
-> (CacheModulePath -> String)
-> ([CacheModulePath] -> ShowS)
-> Show CacheModulePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheModulePath -> ShowS
showsPrec :: Int -> CacheModulePath -> ShowS
$cshow :: CacheModulePath -> String
show :: CacheModulePath -> String
$cshowList :: [CacheModulePath] -> ShowS
showList :: [CacheModulePath] -> ShowS
Show, ReadPrec [CacheModulePath]
ReadPrec CacheModulePath
Int -> ReadS CacheModulePath
ReadS [CacheModulePath]
(Int -> ReadS CacheModulePath)
-> ReadS [CacheModulePath]
-> ReadPrec CacheModulePath
-> ReadPrec [CacheModulePath]
-> Read CacheModulePath
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CacheModulePath
readsPrec :: Int -> ReadS CacheModulePath
$creadList :: ReadS [CacheModulePath]
readList :: ReadS [CacheModulePath]
$creadPrec :: ReadPrec CacheModulePath
readPrec :: ReadPrec CacheModulePath
$creadListPrec :: ReadPrec [CacheModulePath]
readListPrec :: ReadPrec [CacheModulePath]
Read, Eq CacheModulePath
Eq CacheModulePath =>
(CacheModulePath -> CacheModulePath -> Ordering)
-> (CacheModulePath -> CacheModulePath -> Bool)
-> (CacheModulePath -> CacheModulePath -> Bool)
-> (CacheModulePath -> CacheModulePath -> Bool)
-> (CacheModulePath -> CacheModulePath -> Bool)
-> (CacheModulePath -> CacheModulePath -> CacheModulePath)
-> (CacheModulePath -> CacheModulePath -> CacheModulePath)
-> Ord CacheModulePath
CacheModulePath -> CacheModulePath -> Bool
CacheModulePath -> CacheModulePath -> Ordering
CacheModulePath -> CacheModulePath -> CacheModulePath
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CacheModulePath -> CacheModulePath -> Ordering
compare :: CacheModulePath -> CacheModulePath -> Ordering
$c< :: CacheModulePath -> CacheModulePath -> Bool
< :: CacheModulePath -> CacheModulePath -> Bool
$c<= :: CacheModulePath -> CacheModulePath -> Bool
<= :: CacheModulePath -> CacheModulePath -> Bool
$c> :: CacheModulePath -> CacheModulePath -> Bool
> :: CacheModulePath -> CacheModulePath -> Bool
$c>= :: CacheModulePath -> CacheModulePath -> Bool
>= :: CacheModulePath -> CacheModulePath -> Bool
$cmax :: CacheModulePath -> CacheModulePath -> CacheModulePath
max :: CacheModulePath -> CacheModulePath -> CacheModulePath
$cmin :: CacheModulePath -> CacheModulePath -> CacheModulePath
min :: CacheModulePath -> CacheModulePath -> CacheModulePath
Ord, CacheModulePath -> CacheModulePath -> Bool
(CacheModulePath -> CacheModulePath -> Bool)
-> (CacheModulePath -> CacheModulePath -> Bool)
-> Eq CacheModulePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheModulePath -> CacheModulePath -> Bool
== :: CacheModulePath -> CacheModulePath -> Bool
$c/= :: CacheModulePath -> CacheModulePath -> Bool
/= :: CacheModulePath -> CacheModulePath -> Bool
Eq)

instance Toml.ToValue LoadCache where
  toValue :: LoadCache -> Value
toValue = LoadCache -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable LoadCache where
  toTable :: LoadCache -> Table
toTable LoadCache
x = [(Text, Value)] -> Table
Toml.table [
    Text
"version" Text -> Int -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= (Int
1 :: Int), -- increase this to invalidate old files
                                  -- also look at the `Toml.FromValue` instance
    Text
"modules" Text -> [Table] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= [
      [(Text, Value)] -> Table
Toml.table ([(Text, Value)] -> Table) -> [(Text, Value)] -> Table
forall a b. (a -> b) -> a -> b
$ [
        case CacheModulePath
k of
          CacheInFile String
a -> Text
"file" Text -> String -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= String
a
          CacheInMem String
a -> Text
"memory" Text -> String -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= String
a,
        Text
"fingerprint" Text -> Fingerprint -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= FullFingerprint -> Fingerprint
moduleFingerprint FullFingerprint
fp,
        Text
"foreign_fingerprints" Text -> [Fingerprint] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Set Fingerprint -> [Fingerprint]
forall a. Set a -> [a]
Set.toList (FullFingerprint -> Set Fingerprint
foreignFingerprints FullFingerprint
fp),
        Text
"include_fingerprints" Text -> [Table] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= [
          [(Text, Value)] -> Table
Toml.table [
            Text
"file" Text -> String -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= String
k1,
            Text
"fingerprint" Text -> Fingerprint -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Fingerprint
v1
          ]
          | (String
k1, Fingerprint
v1) <- Map String Fingerprint -> [(String, Fingerprint)]
forall k a. Map k a -> [(k, a)]
Map.assocs (FullFingerprint -> Map String Fingerprint
includeFingerprints FullFingerprint
fp)
        ]
      ] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
      [ Text
"docstring_result" Text -> Bool -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Bool
result
        | Just Bool
result <- [CacheEntry -> Maybe Bool
cacheDocstringResult CacheEntry
v]
      ]
      | (CacheModulePath
k,CacheEntry
v) <- Map CacheModulePath CacheEntry -> [(CacheModulePath, CacheEntry)]
forall k a. Map k a -> [(k, a)]
Map.assocs (LoadCache -> Map CacheModulePath CacheEntry
cacheModules LoadCache
x)
      , let fp :: FullFingerprint
fp = CacheEntry -> FullFingerprint
cacheFingerprint CacheEntry
v
    ]]

instance Toml.FromValue LoadCache where
  fromValue :: forall l. Value' l -> Matcher l LoadCache
fromValue = ParseTable l LoadCache -> Value' l -> Matcher l LoadCache
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue
   do Int
1 <- Text -> ParseTable l Int
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"version" :: Toml.ParseTable l Int
      [(CacheModulePath, CacheEntry)]
kvs <- Text
-> (Value' l -> Matcher l [(CacheModulePath, CacheEntry)])
-> ParseTable l [(CacheModulePath, CacheEntry)]
forall l a. Text -> (Value' l -> Matcher l a) -> ParseTable l a
Toml.reqKeyOf Text
"modules"
           ((Value' l -> Matcher l [(CacheModulePath, CacheEntry)])
 -> ParseTable l [(CacheModulePath, CacheEntry)])
-> (Value' l -> Matcher l [(CacheModulePath, CacheEntry)])
-> ParseTable l [(CacheModulePath, CacheEntry)]
forall a b. (a -> b) -> a -> b
$ (Int -> Value' l -> Matcher l (CacheModulePath, CacheEntry))
-> Value' l -> Matcher l [(CacheModulePath, CacheEntry)]
forall l a.
(Int -> Value' l -> Matcher l a) -> Value' l -> Matcher l [a]
Toml.listOf \ Int
_ix ->
             ParseTable l (CacheModulePath, CacheEntry)
-> Value' l -> Matcher l (CacheModulePath, CacheEntry)
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue
             do CacheModulePath
k <- [KeyAlt l CacheModulePath] -> ParseTable l CacheModulePath
forall l a. [KeyAlt l a] -> ParseTable l a
Toml.pickKey [
                    Text
-> (Value' l -> Matcher l CacheModulePath)
-> KeyAlt l CacheModulePath
forall l a. Text -> (Value' l -> Matcher l a) -> KeyAlt l a
Toml.Key Text
"memory" ((String -> CacheModulePath)
-> Matcher l String -> Matcher l CacheModulePath
forall a b. (a -> b) -> Matcher l a -> Matcher l b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> CacheModulePath
CacheInMem (Matcher l String -> Matcher l CacheModulePath)
-> (Value' l -> Matcher l String)
-> Value' l
-> Matcher l CacheModulePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue),
                    Text
-> (Value' l -> Matcher l CacheModulePath)
-> KeyAlt l CacheModulePath
forall l a. Text -> (Value' l -> Matcher l a) -> KeyAlt l a
Toml.Key Text
"file" ((String -> CacheModulePath)
-> Matcher l String -> Matcher l CacheModulePath
forall a b. (a -> b) -> Matcher l a -> Matcher l b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> CacheModulePath
CacheInFile (Matcher l String -> Matcher l CacheModulePath)
-> (Value' l -> Matcher l String)
-> Value' l
-> Matcher l CacheModulePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue)
                  ]
                Fingerprint
fp <- Text -> ParseTable l Fingerprint
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"fingerprint"
                [Fingerprint]
foreigns <- Text -> ParseTable l [Fingerprint]
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"foreign_fingerprints"
                [(String, Fingerprint)]
includes <- Text
-> (Value' l -> Matcher l [(String, Fingerprint)])
-> ParseTable l [(String, Fingerprint)]
forall l a. Text -> (Value' l -> Matcher l a) -> ParseTable l a
Toml.reqKeyOf Text
"include_fingerprints"
                          ((Value' l -> Matcher l [(String, Fingerprint)])
 -> ParseTable l [(String, Fingerprint)])
-> (Value' l -> Matcher l [(String, Fingerprint)])
-> ParseTable l [(String, Fingerprint)]
forall a b. (a -> b) -> a -> b
$ (Int -> Value' l -> Matcher l (String, Fingerprint))
-> Value' l -> Matcher l [(String, Fingerprint)]
forall l a.
(Int -> Value' l -> Matcher l a) -> Value' l -> Matcher l [a]
Toml.listOf \ Int
_ix ->
                            ParseTable l (String, Fingerprint)
-> Value' l -> Matcher l (String, Fingerprint)
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue
                          (ParseTable l (String, Fingerprint)
 -> Value' l -> Matcher l (String, Fingerprint))
-> ParseTable l (String, Fingerprint)
-> Value' l
-> Matcher l (String, Fingerprint)
forall a b. (a -> b) -> a -> b
$ (,) (String -> Fingerprint -> (String, Fingerprint))
-> ParseTable l String
-> ParseTable l (Fingerprint -> (String, Fingerprint))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l String
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"file"
                                ParseTable l (Fingerprint -> (String, Fingerprint))
-> ParseTable l Fingerprint -> ParseTable l (String, Fingerprint)
forall a b.
ParseTable l (a -> b) -> ParseTable l a -> ParseTable l b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> ParseTable l Fingerprint
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"fingerprint"
                Maybe Bool
checkResult <- Text -> ParseTable l (Maybe Bool)
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"docstring_result"
                (CacheModulePath, CacheEntry)
-> ParseTable l (CacheModulePath, CacheEntry)
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheModulePath
k, CacheEntry
                  { cacheFingerprint :: FullFingerprint
cacheFingerprint = FullFingerprint
                      { moduleFingerprint :: Fingerprint
moduleFingerprint = Fingerprint
fp
                      , foreignFingerprints :: Set Fingerprint
foreignFingerprints = [Fingerprint] -> Set Fingerprint
forall a. Ord a => [a] -> Set a
Set.fromList [Fingerprint]
foreigns
                      , includeFingerprints :: Map String Fingerprint
includeFingerprints = [(String, Fingerprint)] -> Map String Fingerprint
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, Fingerprint)]
includes
                      }
                  , cacheDocstringResult :: Maybe Bool
cacheDocstringResult = Maybe Bool
checkResult
                  })
      LoadCache -> ParseTable l LoadCache
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadCache {
        cacheModules :: Map CacheModulePath CacheEntry
cacheModules = [(CacheModulePath, CacheEntry)] -> Map CacheModulePath CacheEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CacheModulePath, CacheEntry)]
kvs
        }

data CacheEntry = CacheEntry
  { CacheEntry -> FullFingerprint
cacheFingerprint :: FullFingerprint
  , CacheEntry -> Maybe Bool
cacheDocstringResult :: Maybe Bool
  }
  deriving (Int -> CacheEntry -> ShowS
[CacheEntry] -> ShowS
CacheEntry -> String
(Int -> CacheEntry -> ShowS)
-> (CacheEntry -> String)
-> ([CacheEntry] -> ShowS)
-> Show CacheEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheEntry -> ShowS
showsPrec :: Int -> CacheEntry -> ShowS
$cshow :: CacheEntry -> String
show :: CacheEntry -> String
$cshowList :: [CacheEntry] -> ShowS
showList :: [CacheEntry] -> ShowS
Show, ReadPrec [CacheEntry]
ReadPrec CacheEntry
Int -> ReadS CacheEntry
ReadS [CacheEntry]
(Int -> ReadS CacheEntry)
-> ReadS [CacheEntry]
-> ReadPrec CacheEntry
-> ReadPrec [CacheEntry]
-> Read CacheEntry
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CacheEntry
readsPrec :: Int -> ReadS CacheEntry
$creadList :: ReadS [CacheEntry]
readList :: ReadS [CacheEntry]
$creadPrec :: ReadPrec CacheEntry
readPrec :: ReadPrec CacheEntry
$creadListPrec :: ReadPrec [CacheEntry]
readListPrec :: ReadPrec [CacheEntry]
Read)

-- | The full fingerprint hashes the module, but
-- also the contents of included files and foreign libraries.
data FullFingerprint = FullFingerprint
  { FullFingerprint -> Fingerprint
moduleFingerprint   :: Fingerprint
  , FullFingerprint -> Map String Fingerprint
includeFingerprints :: Map FilePath Fingerprint
  , FullFingerprint -> Set Fingerprint
foreignFingerprints :: Set Fingerprint
  }
  deriving (FullFingerprint -> FullFingerprint -> Bool
(FullFingerprint -> FullFingerprint -> Bool)
-> (FullFingerprint -> FullFingerprint -> Bool)
-> Eq FullFingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FullFingerprint -> FullFingerprint -> Bool
== :: FullFingerprint -> FullFingerprint -> Bool
$c/= :: FullFingerprint -> FullFingerprint -> Bool
/= :: FullFingerprint -> FullFingerprint -> Bool
Eq, Int -> FullFingerprint -> ShowS
[FullFingerprint] -> ShowS
FullFingerprint -> String
(Int -> FullFingerprint -> ShowS)
-> (FullFingerprint -> String)
-> ([FullFingerprint] -> ShowS)
-> Show FullFingerprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FullFingerprint -> ShowS
showsPrec :: Int -> FullFingerprint -> ShowS
$cshow :: FullFingerprint -> String
show :: FullFingerprint -> String
$cshowList :: [FullFingerprint] -> ShowS
showList :: [FullFingerprint] -> ShowS
Show, ReadPrec [FullFingerprint]
ReadPrec FullFingerprint
Int -> ReadS FullFingerprint
ReadS [FullFingerprint]
(Int -> ReadS FullFingerprint)
-> ReadS [FullFingerprint]
-> ReadPrec FullFingerprint
-> ReadPrec [FullFingerprint]
-> Read FullFingerprint
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS FullFingerprint
readsPrec :: Int -> ReadS FullFingerprint
$creadList :: ReadS [FullFingerprint]
readList :: ReadS [FullFingerprint]
$creadPrec :: ReadPrec FullFingerprint
readPrec :: ReadPrec FullFingerprint
$creadListPrec :: ReadPrec [FullFingerprint]
readListPrec :: ReadPrec [FullFingerprint]
Read)

-- | Directory where to store the project state.
-- XXX: This should probably be a parameter
metaDir :: FilePath
metaDir :: String
metaDir = String
".cryproject"

loadCachePath :: FilePath
loadCachePath :: String
loadCachePath = String
metaDir String -> ShowS
FP.</> String
"loadcache.toml"

emptyLoadCache :: LoadCache
emptyLoadCache :: LoadCache
emptyLoadCache = LoadCache { cacheModules :: Map CacheModulePath CacheEntry
cacheModules = Map CacheModulePath CacheEntry
forall a. Monoid a => a
mempty }

loadLoadCache :: IO LoadCache
loadLoadCache :: IO LoadCache
loadLoadCache =
 do Text
txt <- String -> IO Text
Text.readFile String
loadCachePath
    case Text -> Result String LoadCache
forall a. FromValue a => Text -> Result String a
Toml.decode Text
txt of
      Toml.Success [String]
_ LoadCache
c -> LoadCache -> IO LoadCache
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadCache
c
      Toml.Failure [String]
_ -> LoadCache -> IO LoadCache
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadCache
emptyLoadCache
  IO LoadCache -> (IOError -> IO LoadCache) -> IO LoadCache
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> LoadCache -> IO LoadCache
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadCache
emptyLoadCache

saveLoadCache :: LoadCache -> IO ()
saveLoadCache :: LoadCache -> IO ()
saveLoadCache LoadCache
cache =
  do Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
metaDir
     String -> String -> IO ()
writeFile String
loadCachePath (TomlDoc -> String
forall a. Show a => a -> String
show (LoadCache -> TomlDoc
forall a. ToTable a => a -> TomlDoc
Toml.encode LoadCache
cache))