-- 
-- (c) Susumu Katayama
--
module MagicHaskeller.MemoToFiles where
import System.IO
import System.Directory(doesFileExist, createDirectoryIfMissing)
import MagicHaskeller.ShortString
import Data.ByteString.Char8      as C
import Data.ByteString.Lazy.Char8 as LC

import Control.Monad.Search.Combinatorial
import MagicHaskeller.DebMT
import MagicHaskeller.Types

import MagicHaskeller.PriorSubsts
import Data.Monoid
import Data.Ix



-- copied from ProgGen.lhs. toMemo削って型変えた．てゆーかそれ以前に，散らばってるfreezePSをProgramGenerator辺りにまとめたい気も
freezePS :: Search m => Type -> PriorSubsts m (Bag e) -> m (Possibility e)
freezePS ty ps
    = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)
      -- in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ unPS ps emptySubst (mxty+1)
      in mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps
      -- in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) $ fps mxty ps
fps :: Search m => Int -> PriorSubsts m es -> m (es,[(Int, Type)],Int)
fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1)
                     return (exprs, filterSubst sub mxty, m)
    where filterSubst :: Subst -> Int -> [(Int, Type)]
	  filterSubst sub  mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.

-- これってProgGen限定か
memoPSRTIO :: ShortString b =>
             MemoCond
                 -> MapType (Matrix (Possibility b))
	         -> (Type -> PriorSubsts (RecompT IO) [b]) -- ^ This will be used instead if the entry is not found.
	         -> Type -> PriorSubsts (RecompT IO) [b]
memoPSRTIO policy mt f t = PS $ \subst mx ->
              let (tn, decoder) = encode t mx
              in (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ (memoRTIO policy mt (\u ->  freezePS u (f u)) tn))


memoRTIO :: ShortString b =>
             MemoCond -- IOを返す．つまり，メモリやハードディスクの空きによっても変えられるようにする．
                 -> MapType (Matrix b)     -- ^ Memoization table for the Ram case.
	         -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found.
	         -> Type -> RecompT IO b
memoRTIO policy mt f t = RcT $ memoer policy mt (\ty -> unRcT (f ty)) t
memoer :: ShortString b =>
          MemoCond
          -> MapType (Matrix b)
	  -> (Type -> Int -> IO [b])
	  -> Type -> Int -> IO [b]
memoer policy mt f ty depth
    = do memotype <- policy ty depth
         case memotype of Recompute -> compute
                          Ram       -> return $ unMx (lookupMT mt ty) !! depth
	                  Disk   fp -> let directory = fp++shows depth "/" -- care about Windows later....
                                           filepath  = directory ++ show ty
			               in do createDirectoryIfMissing True directory
                                             memoToFile readsBriefly showsBriefly filepath compute
      where compute = f ty depth
data MemoType = Recompute -- ^ Recompute instead of memoizing.
              | Ram       -- ^ Use the memoization table based on lazy evaluation, like in older versions.
              | Disk FilePath -- ^ Use the directory specified by @FilePath@ as the persistent memoization table.
type MemoCond = Type -> Int -> IO MemoType


-- | General-purposed memoizer (This could be put in a different module.)
memoToFile :: (C.ByteString -> Maybe (a,C.ByteString)) -> (a -> LC.ByteString -> LC.ByteString)
           -> FilePath -- ^ where to memoize
           -> IO a     -- ^ invoked if there is no such file
           -> IO a
memoToFile parser printer filepath compute
    = let write = do result <- compute
                     LC.writeFile filepath (printer result LC.empty)
		     return result
      in do there <- doesFileExist filepath
            if there then do cs <- C.readFile filepath -- Read strictly, and close (not semi-close) it. System.IO.readFile cannot achieve this behavior. 
			     case parser cs of Just (x,_) -> return x
					       _          -> do -- If the file is broken, just fix it. でも誰かが書き込み中だと困る?
                                                              System.IO.hPutStrLn stderr ("File " ++ filepath ++ " was broken.")
                                                              write
	             else write