-- 
-- (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 :: Type -> PriorSubsts m (Bag e) -> m (Possibility e)
freezePS Type
ty PriorSubsts m (Bag e)
ps
    = let mxty :: TyVar
mxty = Type -> TyVar
maxVarID Type
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 (Possibility e -> Possibility e -> Possibility e)
-> (Possibility e -> Possibility e -> Ordering)
-> m (Possibility e)
-> m (Possibility e)
forall (m :: * -> *) k.
Search m =>
(k -> k -> k) -> (k -> k -> Ordering) -> m k -> m k
mergesortDepthWithBy (\(Bag e
xs,[(TyVar, Type)]
k,TyVar
i) (Bag e
ys,[(TyVar, Type)]
_,TyVar
_) -> (Bag e
xs Bag e -> Bag e -> Bag e
forall a. Monoid a => a -> a -> a
`mappend` Bag e
ys, [(TyVar, Type)]
k, TyVar
i)) (\(Bag e
_,[(TyVar, Type)]
k,TyVar
_) (Bag e
_,[(TyVar, Type)]
l,TyVar
_) -> [(TyVar, Type)]
k [(TyVar, Type)] -> [(TyVar, Type)] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [(TyVar, Type)]
l) (m (Possibility e) -> m (Possibility e))
-> m (Possibility e) -> m (Possibility e)
forall a b. (a -> b) -> a -> b
$ TyVar -> PriorSubsts m (Bag e) -> m (Possibility e)
forall (m :: * -> *) es.
Search m =>
TyVar -> PriorSubsts m es -> m (es, [(TyVar, Type)], TyVar)
fps TyVar
mxty PriorSubsts m (Bag e)
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 => TyVar -> PriorSubsts m es -> m (es,[(TyVar, Type)],TyVar)
fps :: TyVar -> PriorSubsts m es -> m (es, [(TyVar, Type)], TyVar)
fps TyVar
mxty (PS [(TyVar, Type)] -> TyVar -> m (es, [(TyVar, Type)], TyVar)
f) = do (es
exprs, [(TyVar, Type)]
sub, TyVar
m) <- [(TyVar, Type)] -> TyVar -> m (es, [(TyVar, Type)], TyVar)
f [(TyVar, Type)]
forall a. [a]
emptySubst (TyVar
mxtyTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1)
                     (es, [(TyVar, Type)], TyVar) -> m (es, [(TyVar, Type)], TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (es
exprs, [(TyVar, Type)] -> TyVar -> [(TyVar, Type)]
filterSubst [(TyVar, Type)]
sub TyVar
mxty, TyVar
m)
    where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]
          filterSubst :: [(TyVar, Type)] -> TyVar -> [(TyVar, Type)]
filterSubst [(TyVar, Type)]
sub  TyVar
mx = [ (TyVar, Type)
t | t :: (TyVar, Type)
t@(TyVar
i,Type
_) <- [(TyVar, Type)]
sub, (TyVar, TyVar) -> TyVar -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (TyVar
0,TyVar
mx) TyVar
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 :: MemoCond
-> MapType (Matrix (Possibility b))
-> (Type -> PriorSubsts (RecompT IO) [b])
-> Type
-> PriorSubsts (RecompT IO) [b]
memoPSRTIO MemoCond
policy MapType (Matrix (Possibility b))
mt Type -> PriorSubsts (RecompT IO) [b]
f Type
t = ([(TyVar, Type)] -> TyVar -> RecompT IO (Possibility b))
-> PriorSubsts (RecompT IO) [b]
forall (m :: * -> *) a.
([(TyVar, Type)] -> TyVar -> m (a, [(TyVar, Type)], TyVar))
-> PriorSubsts m a
PS (([(TyVar, Type)] -> TyVar -> RecompT IO (Possibility b))
 -> PriorSubsts (RecompT IO) [b])
-> ([(TyVar, Type)] -> TyVar -> RecompT IO (Possibility b))
-> PriorSubsts (RecompT IO) [b]
forall a b. (a -> b) -> a -> b
$ \[(TyVar, Type)]
subst TyVar
mx ->
              let (Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
t TyVar
mx
              in ((Possibility b -> Possibility b)
-> RecompT IO (Possibility b) -> RecompT IO (Possibility b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ([b]
exprs, [(TyVar, Type)]
sub, TyVar
m) -> ([b]
exprs, Decoder -> [(TyVar, Type)] -> [(TyVar, Type)]
retrieve Decoder
decoder [(TyVar, Type)]
sub [(TyVar, Type)] -> [(TyVar, Type)] -> [(TyVar, Type)]
`plusSubst` [(TyVar, Type)]
subst, TyVar
mxTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
m)) (RecompT IO (Possibility b) -> RecompT IO (Possibility b))
-> RecompT IO (Possibility b) -> RecompT IO (Possibility b)
forall a b. (a -> b) -> a -> b
$ (MemoCond
-> (Type -> Int -> IO [Possibility b])
-> (Type -> RecompT IO (Possibility b))
-> Type
-> RecompT IO (Possibility b)
forall b.
ShortString b =>
MemoCond
-> (Type -> Int -> IO [b])
-> (Type -> RecompT IO b)
-> Type
-> RecompT IO b
memoRTIO MemoCond
policy (\Type
ty Int
depth -> [Possibility b] -> IO [Possibility b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Possibility b] -> IO [Possibility b])
-> [Possibility b] -> IO [Possibility b]
forall a b. (a -> b) -> a -> b
$ Matrix (Possibility b) -> Stream [Possibility b]
forall a. Matrix a -> Stream (Bag a)
unMx (MapType (Matrix (Possibility b)) -> Type -> Matrix (Possibility b)
forall a. MapType a -> Type -> a
lookupMT MapType (Matrix (Possibility b))
mt Type
ty) Stream [Possibility b] -> Int -> [Possibility b]
forall a. [a] -> Int -> a
!! Int
depth) (\Type
u ->  Type -> PriorSubsts (RecompT IO) [b] -> RecompT IO (Possibility b)
forall (m :: * -> *) e.
Search m =>
Type -> PriorSubsts m (Bag e) -> m (Possibility e)
freezePS Type
u (Type -> PriorSubsts (RecompT IO) [b]
f Type
u)) Type
tn))


memoRTIO :: ShortString b =>
             MemoCond
                 -> (Type -> Int -> IO [b]) -- ^ look up the memoization table in the RAM.
                 -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found.
                 -> Type -> RecompT IO b
memoRTIO :: MemoCond
-> (Type -> Int -> IO [b])
-> (Type -> RecompT IO b)
-> Type
-> RecompT IO b
memoRTIO MemoCond
policy Type -> Int -> IO [b]
lor Type -> RecompT IO b
f Type
t = (Int -> IO [b]) -> RecompT IO b
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ((Int -> IO [b]) -> RecompT IO b)
-> (Int -> IO [b]) -> RecompT IO b
forall a b. (a -> b) -> a -> b
$ MemoCond
-> (Type -> Int -> IO [b])
-> (Type -> Int -> IO [b])
-> Type
-> Int
-> IO [b]
forall b.
ShortString b =>
MemoCond
-> (Type -> Int -> IO [b])
-> (Type -> Int -> IO [b])
-> Type
-> Int
-> IO [b]
memoer MemoCond
policy Type -> Int -> IO [b]
lor (\Type
ty -> RecompT IO b -> Int -> IO [b]
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (Type -> RecompT IO b
f Type
ty)) Type
t
memoer :: ShortString b =>
          MemoCond
          -> (Type -> Int -> IO [b])
          -> (Type -> Int -> IO [b])
          -> Type -> Int -> IO [b]
memoer :: MemoCond
-> (Type -> Int -> IO [b])
-> (Type -> Int -> IO [b])
-> Type
-> Int
-> IO [b]
memoer MemoCond
policy Type -> Int -> IO [b]
lor Type -> Int -> IO [b]
f Type
ty Int
depth
    = do MemoType
memotype <- MemoCond
policy Type
ty Int
depth
         case MemoType
memotype of MemoType
Recompute -> IO [b]
compute
                          MemoType
Ram       -> Type -> Int -> IO [b]
lor Type
ty Int
depth
                          Disk   FilePath
fp | FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length FilePath
filepath Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
250 -> do -- If I remember correctly, UNIX does not permit filenames longer than 255 letters.
                                             -- System.IO.putStrLn "Hit!"
                                             -- System.IO.putStrLn ("Directory name: "++directory)
                                             -- System.IO.putStrLn ("FilePath: "++ filepath)
                                             Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
directory
                                             (ByteString -> Maybe [b])
-> ([b] -> ByteString) -> FilePath -> IO [b] -> IO [b]
forall a.
(ByteString -> Maybe a)
-> (a -> ByteString) -> FilePath -> IO a -> IO a
memoToFile ByteString -> Maybe [b]
forall a. ShortString a => ByteString -> Maybe a
readBriefly [b] -> ByteString
forall a. ShortString a => a -> ByteString
showBriefly FilePath
filepath IO [b]
compute
                                    | Bool
otherwise -> IO [b]
compute -- This is safer than Ram. Still this behavior can be overridden by specifying the MemoCond accordingly
                                                           -- (though that can be unsafe).
                              where
                                directory :: FilePath
directory = FilePath
fpFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows Int
depth FilePath
"/" -- care about Windows later....
                                filepath :: FilePath
filepath  = FilePath
directory FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
ty
      where compute :: IO [b]
compute = Type -> Int -> IO [b]
f Type
ty Int
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 -- IOを返す．つまり，メモリやハードディスクの空きによっても変えられるようにする．


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