Cached.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Data.Cached where

import Protolude

import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text
import Data.Text.Read
import Development.Shake
import Development.Shake.FilePath
import System.Directory
import Test.QuickCheck
import Test.QuickCheck.Assertions
import Test.Util

import Data.Cached
import Data.Cached.Internal

readInt :: Text -> Either Text Int
readInt = bimap pack fst . signed decimal

val :: Int -> FilePath -> Cached Int
val x p = pure x
          & cache p show readInt

addOne :: FilePath -> Cached (Int -> Int)
addOne p = pure (+ 1)

shakeGo testDir = shakeArgs shakeOptions
  { shakeReport = [testDir </> "shakeReport.html"]
  , shakeFiles = testDir </> ".shake/"
  }

 
-- Test that a file exists and contains the appropriate value.
testFile :: FilePath -> Text -> IO Property
testFile path content = do
  exists <- System.Directory.doesFileExist path
  if not exists
    then return $ counterexample ("File " <> path <> " does not exist") False
    else do 
      valInFile <- readFile path
      return $ counterexample ("Cached file " <> path <> " contains "
                                <> show valInFile
                                <> " but should contain \""
                                <> unpack content
                                <> "\".")
                              (valInFile == content)

-- Run build in a clean directory
runClean :: FilePath -> Cached a -> IO ()
runClean dir x = do
  rmRec dir
  shakeGo dir $ toShakeRules x

-- Test function application.
testFunAp :: FilePath -> IO () -> (Text, Text) ->  Property
testFunAp dir touch (expectedA, expectedFA) = once $ ioProperty $ do
  let a x = pure x
          & cache (dir </> "a") show readInt
  let f i a = pure (+ (10 * i)) <*> a
           & cache (dir </> "fa") show readInt

  -- Delete shake cache files
  rmRec dir

  -- Build "a" once
  shakeGo dir $ do
    toShakeRules $ f 1 (a 1)

  touch

  -- Build cache
  shakeGo dir $ do
    toShakeRules $ f 2 (a 2)

  -- Test the cache files
  testA <- testFile (dir </> "a") expectedA
  testFA <- testFile (dir </> "fa") expectedFA

  return $ testA .&&. testFA



---- Tests ----

---- Single values depending on no other cached value

-- Check that when a value is computed and there is no cache file, it is created.
prop_SinValCreaCache :: Property
prop_SinValCreaCache = ioProperty $ do
  let a = val 1 "test-output/formulas/Util/Cached/SinValCreaCache/a"

  -- Make sure the directory state is clean
  rmRec "test-output/formulas/Util/Cached/SinValCreaCache"

  -- Build the cache
  shakeGo "test-output/formulas/Util/Cached/SinValCreaCache/" $ toShakeRules a

  -- Test if the file was written and contains the appropriate value
  testFile "test-output/formulas/Util/Cached/SinValCreaCache/a" "1"
 

-- Check that a value is not recomputed when the cache file already exists
prop_SinValNoRecomp :: Property
prop_SinValNoRecomp = ioProperty $ do
  let a x = val x "test-output/formulas/Util/Cached/SinValNoRecomp/a"

  -- Make sure the file is not present
  rmRec "test-output/formulas/Util/Cached/SinValNoRecomp"

  -- Build the cache once.
  shakeGo "test-output/formulas/Util/Cached/SinValNoRecomp" $ toShakeRules (a 1)

  -- Rebuild, changing the value.
  shakeGo "test-output/formulas/Util/Cached/SinValNoRecomp" $ toShakeRules (a 2)

  -- Test if the file was written and contains the appropriate value
  testFile "test-output/formulas/Util/Cached/SinValNoRecomp/a" "1"


-- Check that a value is recomputed when the cache file has changed.
prop_SinValRecomp :: Property
prop_SinValRecomp = ioProperty $ do
  let a x = val x "test-output/formulas/Util/Cached/SinValRecomp/a"

  -- Make sure the file is not present
  rmRec  "test-output/formulas/Util/Cached/SinValRecomp"

  -- Build the cache once.
  shakeGo "test-output/formulas/Util/Cached/SinValRecomp" $ toShakeRules (a 1)

  -- Modify the cache file. (delay to make sure the file modification date is different)
  threadDelay 5000
  writeFile "test-output/formulas/Util/Cached/SinValRecomp/a" "2"

  -- Rebuild, changing the value.
  shakeGo "test-output/formulas/Util/Cached/SinValRecomp/" $ toShakeRules (a 3)

  -- Test if the file was written and contains the appropriate value
  testFile "test-output/formulas/Util/Cached/SinValRecomp/a" "3"


---- Function application (cached values depending on another cached value)

-- State: A absent, FA absent
-- Check that when no cache file is present, the function application `pure f <*> a` creates a cache file for `a` and for the last value `f <$> a`.
prop_FunApAAbsentFAAbsent :: Property
prop_FunApAAbsentFAAbsent =
  testFunAp "test-output/formulas/Util/Cached/FunApAAbsentFAAbsent"
            (do
              rmFile "test-output/formulas/Util/Cached/FunApAAbsentFAAbsent/a"
              rmFile "test-output/formulas/Util/Cached/FunApAAbsentFAAbsent/fa")
            ("2", "22")

-- State: A unchanged, FA absent
-- Check that when the cache file for `a` only already exists, a is not recomputed and the cache file for `f <$> a` is created.
prop_FunApAUnchangedFAAbsent :: Property
prop_FunApAUnchangedFAAbsent =
  testFunAp "test-output/formulas/Util/Cached/FunApAUnchangedFAAbsent"
            (do
              rmFile "test-output/formulas/Util/Cached/FunApAUnchangedFAAbsent/fa")
            ("1", "21")

-- State: A modified, FA absent
-- Check that a is recomputed and FA is recomputed
prop_FunApAModifiedFAAbsent :: Property
prop_FunApAModifiedFAAbsent =
  testFunAp "test-output/formulas/Util/Cached/FunApAModifiedFAAbsent"
            (do
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAModifiedFAAbsent/a" "3"
              rmFile "test-output/formulas/Util/Cached/FunApAModifiedFAAbsent/fa")
            ("2", "22")




-- State: A absent, FA unchanged
-- Check that "a" and "fa" are recomputed
prop_FunApAAbsentFAUnchanged :: Property
prop_FunApAAbsentFAUnchanged =
  testFunAp "test-output/formulas/Util/Cached/FunApAAbsentFAUnchanged"
            (do
              threadDelay 5000
              rmFile "test-output/formulas/Util/Cached/FunApAAbsentFAUnchanged/a")
            ("2", "22")

-- State: A unchanged, FA unchanged
-- Check that nothing is recomputed
prop_FunApAUnchangedFAUnchanged :: Property
prop_FunApAUnchangedFAUnchanged =
  testFunAp "test-output/formulas/Util/Cached/FunApAUnchangedFAUnchanged"
            (do
              return ())
            ("1", "11")

-- State: A modified, FA unchanged
-- Check that a is recomputed and FA is recomputed
prop_FunApAModifiedFAUnchanged :: Property
prop_FunApAModifiedFAUnchanged =
  testFunAp "test-output/formulas/Util/Cached/FunApAModifiedFAUnchanged"
            (do
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAModifiedFAUnchanged/a" "3")
            ("2", "22")




-- State: A absent, FA modified
-- Check that both are recomputed
prop_FunApAAbsentFAModified :: Property
prop_FunApAAbsentFAModified =
  testFunAp "test-output/formulas/Util/Cached/FunApAAbsentFAModified"
            (do
              rmFile "test-output/formulas/Util/Cached/FunApAAbsentFAModified/a"
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAAbsentFAModified/fa" "77")
            ("2", "22")

-- State: A unchanged, FA modified
-- Check that "fa" is recomputed but not "a" 
prop_FunApAUnchangedFAModified :: Property
prop_FunApAUnchangedFAModified =
  testFunAp "test-output/formulas/Util/Cached/FunApAUnchangedFAModified"
            (do
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAUnchangedFAModified/fa" "77")
            ("1", "21")

-- State: A modified, FA modified
-- Check that both are recomputed.
prop_FunApAModifiedFAModified :: Property
prop_FunApAModifiedFAModified =
  testFunAp "test-output/formulas/Util/Cached/FunApAModifiedFAModified"
            (do
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAModifiedFAModified/a" "3"
              threadDelay 5000
              writeFile "test-output/formulas/Util/Cached/FunApAModifiedFAModified/fa" "77")
            ("2", "22")


-- State: A absent, FA absent
-- Check with the Functor operator "f <$> a"
prop_FunApCompAllFunctor :: Property
prop_FunApCompAllFunctor = once $ ioProperty $ do
  let a = pure 1
          & cache "test-output/formulas/Util/Cached/FunApCompAllFunctor/a" show readInt
  let fa = pure (+ 1) <*> a
           & cache "test-output/formulas/Util/Cached/FunApCompAllFunctor/fa" show readInt

  -- Delete shake cache files
  rmRec "test-output/formulas/Util/Cached/FunApCompAllFunctor"

  -- Build cache
  shakeGo "test-output/formulas/Util/Cached/FunApCompAllFunctor/" $ do
    toShakeRules fa

  -- Test the cache files
  testA <- testFile "test-output/formulas/Util/Cached/FunApCompAllFunctor/a" "1"
  testFA <- testFile "test-output/formulas/Util/Cached/FunApCompAllFunctor/fa" "2"

  return $ testA .&&. testFA


---- Monoid

-- The monoid is left-biased: when two different values are cached to the same
-- target, the first is kept.
prop_MonoidCacheTwice :: Property
prop_MonoidCacheTwice = ioProperty $ do
  let mon = cache "test-output/formulas/Util/Cached/Monoid/CacheTwice/a"
                  (show . getSum) (fmap Sum . readInt) (pure (Sum 1))
         <> cache "test-output/formulas/Util/Cached/Monoid/CacheTwice/a"
                  (show . getSum) (fmap Sum . readInt) (pure (Sum 2))
  runClean "test-output/formulas/Util/Cached/Monoid/CacheTwice" mon
  testFile "test-output/formulas/Util/Cached/Monoid/CacheTwice/a" "1"


---- Applicative

-- The applicative is left-biased: Check that caching twice to the same file
-- only builds the first.
prop_ApplicativeCacheTwice :: Property
prop_ApplicativeCacheTwice = ioProperty $ do
  let ap = cache "test-output/formulas/Util/Cached/Applicative/CacheTwice/a"
                  (\_ -> "1") (\_ -> Right (+ 1)) (pure (+ 1))
       <*> cache "test-output/formulas/Util/Cached/Applicative/CacheTwice/a"
                  (\_ -> "2") (\_ -> Right 1) (pure 1)
                  
  runClean "test-output/formulas/Util/Cached/Applicative/CacheTwice" ap
  testFile "test-output/formulas/Util/Cached/Applicative/CacheTwice/a" "1"


---- Interface functions examples

prop_source :: SimplePath -> Either Text Int -> Property
prop_source (SimplePath p) es =
  let dir="test-output/formulas/Util/Cached/Interface/source"
      path = dir </> p
      c = source path (bimap pack identity . readEither . unpack)
      -- to cover the case when es is (Left t) and t represents an Int
      es' = case es of
                      Left t -> case readMaybe (unpack t) of
                                  Nothing -> es
                                  Just anInt -> Right anInt
                      _ -> es
  in ioProperty $ do
    setDir dir [(path, case es of Right i -> show i; Left t -> t)]
    ev <- getValue c
    return $ counterexample (show (ev, es')) $ case (ev, es') of
      (Left errv, Left _ ) -> errv == "Error reading file " <> pack path <> ": Prelude.read: no parse"
      (Right v, Right s) -> v == s
      _ -> False

prop_source' :: SimplePath -> Either Text Int -> Property
prop_source' (SimplePath p) es =
  let dir="test-output/formulas/Util/Cached/Interface/source'"
      path = dir </> p
  in ioProperty $ do
    setDir dir [(path, case es of Right i -> show i; Left t -> t)]
    eqCached (source' path :: Cached Int)
             (source path (bimap pack identity . readEither . unpack) :: Cached Int)

prop_fromIO :: DirectoryTree -> InfiniteList Text -> Property
prop_fromIO dt (InfiniteList infTexts _) =
  let dir="test-output/formulas/Util/Cached/Interface/fromIO"
      paths = fmap (dir </>) (directoryTreePaths dt)
      texts = List.take (List.length paths) infTexts
      c = fromIO (Set.fromList paths) (foldMap readFile paths)
  in ioProperty $ do
    setDir dir (Protolude.zip paths texts)
    e <- getValue $ liftA2 (==) c (pure $ mconcat texts)
    return $ case e of
      Left _ -> False
      Right b -> b

prop_cache :: Property
prop_cache = once $
  let dir = "test-output/formulas/Util/Cached/Interface/cache"
      c1 = cache ( dir </> "c1" )
                 show
                 (bimap pack identity . readEither . unpack)
                 ( pure 1 ) :: Cached Int
      c2 = cache ( dir </> "c2" ) 
                 show
                 (bimap pack identity . readEither . unpack)
                 ( pure 2 ) :: Cached Int
      c3 = cache ( dir </> "c3" ) 
                 show
                 (bimap pack identity . readEither . unpack)
                 ( c1 + c2 ) :: Cached Int
  in ioProperty $ do
    setDir dir []
    test1 <- testCached c1 (Right 1) (Set.singleton $ dir </> "c1")
               (Map.fromList [(dir </> "c1", (Right "1", mempty))])
    test2 <- testCached c3 (Right 3) (Set.singleton $ dir </> "c3")
               (Map.fromList [(dir </> "c3", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2

prop_cache' :: Property
prop_cache' = once $
  let dir = "test-output/formulas/Util/Cached/Interface/cache'"
      c1 = cache' ( dir </> "c1" ) ( pure 1 ) :: Cached Int
      c2 = cache' ( dir </> "c2" ) ( pure 2 ) :: Cached Int
      c3 = cache' ( dir </> "c3" ) ( c1 + c2 ) :: Cached Int
  in ioProperty $ do
    setDir dir []
    test1 <- testCached c1 (Right 1) (Set.singleton $ dir </> "c1")
               (Map.fromList [(dir </> "c1", (Right "1", mempty))])
    test2 <- testCached c3 (Right 3) (Set.singleton $ dir </> "c3")
               (Map.fromList [(dir </> "c3", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2


prop_cacheIO :: Property
prop_cacheIO = once $
  let dir = "test-output/formulas/Util/Cached/Interface/cacheIO"
      c1 = cacheIO ( dir </> "c1" )
                  ( writeFile (dir </> "c1") . show )
                  ( bimap pack identity . readEither . unpack
                    <$> readFile (dir </> "c1") )
                  ( pure 1 ) :: Cached Int
      c2 = cacheIO ( dir </> "c2" )
                  ( writeFile (dir </> "c2") . show )
                  ( bimap pack identity . readEither . unpack
                    <$> readFile (dir </> "c2") )
                  ( pure 2 ) :: Cached Int
      c3 = cacheIO ( dir </> "c3" )
                  ( writeFile (dir </> "c3") . show )
                  ( bimap pack identity . readEither . unpack
                    <$> readFile (dir </> "c3") )
                  ( c1 + c2 ) :: Cached Int
  in ioProperty $ do
    setDir dir []
    test1 <- testCached c1 (Right 1) (Set.singleton $ dir </> "c1")
               (Map.fromList [(dir </> "c1", (Right "1", mempty))])
    test2 <- testCached c3 (Right 3) (Set.singleton $ dir </> "c3")
               (Map.fromList [(dir </> "c3", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2

prop_sink :: Property
prop_sink = once $
  let dir = "test-output/formulas/Util/Cached/Interface/sink"
      c1 = cache' ( dir </> "c1" ) ( pure 1 ) :: Cached Int
      c2 = cache' ( dir </> "c2" ) ( pure 2 ) :: Cached Int
      s1 = sink ( dir </> "s1" ) (Right . show) ( pure (1 :: Int) )
      s2 = sink ( dir </> "s2" ) (Right . show) ( c1 + c2 )
  in ioProperty $ do
    setDir dir []
    test1 <- testCached s1 (Right ()) mempty
               (Map.fromList [(dir </> "s1", (Right "1", mempty))])
    test2 <- testCached s2 (Right ()) mempty
               (Map.fromList [(dir </> "s2", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2

prop_sink' :: Property
prop_sink' = once $
  let dir = "test-output/formulas/Util/Cached/Interface/sink'"
      c1 = cache' ( dir </> "c1" ) ( pure 1 ) :: Cached Int
      c2 = cache' ( dir </> "c2" ) ( pure 2 ) :: Cached Int
      s1 = sink' ( dir </> "s1" ) (pure 1):: Cached ()
      s2 = sink' ( dir </> "s2" ) (c1 + c2) :: Cached ()
  in ioProperty $ do
    setDir dir []
    test1 <- testCached s1 (Right ()) mempty
               (Map.fromList [(dir </> "s1", (Right "1", mempty))])
    test2 <- testCached s2 (Right ()) mempty
               (Map.fromList [(dir </> "s2", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2

prop_sinkIO :: Property
prop_sinkIO = once $
  let dir = "test-output/formulas/Util/Cached/Interface/sinkIO"
      c1 = cache' ( dir </> "c1" ) ( pure 1 ) :: Cached Int
      c2 = cache' ( dir </> "c2" ) ( pure 2 ) :: Cached Int
      s1 = sinkIO ( dir </> "s1" )
                  ( fmap Right . writeFile (dir </> "s1") . show )
                  (pure 1):: Cached ()
      s2 = sinkIO ( dir </> "s2" )
                  ( fmap Right . writeFile (dir </> "s2") . show )
                  (c1 + c2) :: Cached ()
  in ioProperty $ do
    setDir dir []
    test1 <- testCached s1 (Right ()) mempty
               (Map.fromList [(dir </> "s1", (Right "1", mempty))])
    test2 <- testCached s2 (Right ()) mempty
               (Map.fromList [(dir </> "s2", (Right "3", Set.fromList [dir </> "c1"
                                                         ,dir </> "c2"]))
                             ,(dir </> "c2", (Right "2", mempty))
                             ,(dir </> "c1", (Right "1", mempty))])
    return $ test1 .&&. test2

prop_trigger :: Property
prop_trigger = once $
  let dir = "test-output/formulas/Util/Cached/Interface/trigger"
      c = trigger ( dir </> "c" )
                  ( Right <$> writeFile (dir </> "c") "1" )
                  ( Set.fromList [dir </> "a"] )
  in ioProperty $ do
    setDir dir []
    testCached c (Right ()) mempty
               (Map.fromList [(dir </> "s1", (Right "1", (Set.fromList [dir </> "a"])))])

runTests = do
  checkOrExit "prop_SinValCreaCache" prop_SinValCreaCache
  checkOrExit "prop_SinValNoRecomp" prop_SinValNoRecomp
  checkOrExit "prop_SinValRecomp" prop_SinValRecomp
  checkOrExit "prop_FunApAAbsentFAAbsent" prop_FunApAAbsentFAAbsent
  checkOrExit "prop_FunApAAbsentFAUnchanged" prop_FunApAAbsentFAUnchanged
  checkOrExit "prop_FunApAAbsentFAModified" prop_FunApAAbsentFAModified
  checkOrExit "prop_FunApAUnchangedFAAbsent" prop_FunApAUnchangedFAAbsent
  checkOrExit "prop_FunApAUnchangedFAUnchanged" prop_FunApAUnchangedFAUnchanged
  checkOrExit "prop_FunApAUnchangedFAModified" prop_FunApAUnchangedFAModified
  checkOrExit "prop_FunApAModifiedFAAbsent" prop_FunApAModifiedFAAbsent
  checkOrExit "prop_FunApAModifiedFAUnchanged" prop_FunApAModifiedFAUnchanged
  checkOrExit "prop_FunApAModifiedFAModified" prop_FunApAModifiedFAModified
  checkOrExit "prop_FunApCompAllFunctor" prop_FunApCompAllFunctor
  checkOrExit "prop_MonoidCacheTwice" prop_MonoidCacheTwice
  checkOrExit "prop_ApplicativeCacheTwice" prop_ApplicativeCacheTwice
  checkOrExit "prop_source" prop_source
  checkOrExit "prop_source'" prop_source'
  checkOrExit "prop_fromIO" prop_fromIO
  checkOrExit "prop_cache" prop_cache
  checkOrExit "prop_cache'" prop_cache'
  checkOrExit "prop_cacheIO" prop_cacheIO
  checkOrExit "prop_sink" prop_sink
  checkOrExit "prop_sink'" prop_sink'
  checkOrExit "prop_sinkIO" prop_sinkIO
  checkOrExit "prop_trigger" prop_trigger