-- 
-- (c) Susumu Katayama
--
\begin{code}
module MagicHaskeller.ClassLib(mkCL, ClassLib(..), mguPrograms) where

import MagicHaskeller.Types
import MagicHaskeller.TyConLib
import Control.Monad
import Data.Monoid
import MagicHaskeller.CoreLang
import Control.Monad.Search.Combinatorial
import MagicHaskeller.PriorSubsts
import Data.List(partition, sortBy, genericLength)
import Data.Ix(inRange)

import MagicHaskeller.ProgramGenerator

import MagicHaskeller.Classify
import MagicHaskeller.Instantiate

import MagicHaskeller.Expression

import MagicHaskeller.T10

import MagicHaskeller.DebMT

traceTy :: p -> a -> a
traceTy p
_    = a -> a
forall a. a -> a
id
-- traceTy fty = trace ("lookup "++ show fty)


type BF = Recomp
-- type BF = DBound

type BFM = Matrix
-- type BFM = DBMemo
fromMemo :: Search m => Matrix a -> m a
fromMemo :: Matrix a -> m a
fromMemo = Matrix a -> m a
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx
toMemo :: Search m => m a -> Matrix a
toMemo :: m a -> Matrix a
toMemo = m a -> Matrix a
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx


newtype ClassLib e = CL (MemoDeb e)

type MemoTrie a = MapType (BFM (Possibility a))

lmt :: MapType a -> Type -> a
lmt MapType a
mt Type
fty =
       Type -> a -> a
forall p a. p -> a -> a
traceTy Type
fty (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
       MapType a -> Type -> a
forall a. MapType a -> Type -> a
lookupMT MapType a
mt Type
fty

lookupFunsPoly :: (Search m, Expression e) => Generator m e -> Generator m e
lookupFunsPoly :: Generator m e -> Generator m e
lookupFunsPoly Generator m e
behalf memodeb :: MemoDeb e
memodeb@(MemoTrie e
mt,[[Prim]]
_,Common
cmn) Type
reqret
    = (Subst -> TyVar -> m (Bag e, Subst, TyVar))
-> PriorSubsts m (Bag e)
forall (m :: * -> *) a.
(Subst -> TyVar -> m (a, Subst, TyVar)) -> PriorSubsts m a
PS (\Subst
subst TyVar
mx ->
              let (Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
reqret TyVar
mx
              in -- ifDepth (<= memodepth (opt cmn))
                         (((Bag e, Subst, TyVar) -> (Bag e, Subst, TyVar))
-> m (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Bag e
exprs, Subst
sub, TyVar
m) -> (Bag e
exprs, Decoder -> Subst -> Subst
retrieve Decoder
decoder Subst
sub Subst -> Subst -> Subst
`plusSubst` Subst
subst, TyVar
mxTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
m)) (m (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar))
-> m (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Matrix (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar)
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMemo (Matrix (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar))
-> Matrix (Bag e, Subst, TyVar) -> m (Bag e, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ MemoTrie e -> Type -> Matrix (Bag e, Subst, TyVar)
forall a. MapType a -> Type -> a
lmt MemoTrie e
mt Type
tn)
                 --        (unPS (behalf memodeb reqret) subst mx) 
         )
                         -- 条件によって再計算したいときはuncommentすべし。メモりは食わないはずなので、常にmemoizeで問題ないはず。

type MemoDeb a = (MemoTrie a, [[Prim]], Common)

mkCL :: Expression e => Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL :: Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL Common
cmn [Typed [CoreExpr]]
classes = MemoDeb e -> ClassLib e
forall e. MemoDeb e -> ClassLib e
CL (MemoDeb e -> ClassLib e) -> MemoDeb e -> ClassLib e
forall a b. (a -> b) -> a -> b
$ [[Prim]] -> Common -> MemoDeb e
forall e. Expression e => [[Prim]] -> Common -> MemoDeb e
mkTrieMD [(Typed [CoreExpr] -> Prim) -> [Typed [CoreExpr]] -> [Prim]
forall a b. (a -> b) -> [a] -> [b]
map Typed [CoreExpr] -> Prim
annotateTCEs [Typed [CoreExpr]]
classes] Common
cmn
mkTrieMD :: (Expression e) => [[Prim]] -> Common -> MemoDeb e
mkTrieMD :: [[Prim]] -> Common -> MemoDeb e
mkTrieMD [[Prim]]
qtl Common
cmn
    = let trie :: MapType (Matrix (Possibility e))
trie = TyConLib
-> (Type -> Matrix (Possibility e))
-> MapType (Matrix (Possibility e))
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Recomp (Possibility e) -> Matrix (Possibility e)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Type -> PriorSubsts Recomp (Bag e) -> Recomp (Possibility e)
forall (m :: * -> *) e.
(Search m, Expression e) =>
Type -> PriorSubsts m (Bag e) -> m (Possibility e)
freezePS Type
ty (Generator Recomp e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguFuns MemoDeb e
memoDeb Type
ty)))
          memoDeb :: MemoDeb e
memoDeb = (MapType (Matrix (Possibility e))
trie,[[Prim]]
qtl,Common
cmn)
      in MemoDeb e
memoDeb

-- moved from DebMT.lhs to avoid cyclic modules.
freezePS :: (Search m, Expression e) => 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 (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,Subst
k,TyVar
i) (Bag e
ys,Subst
_,TyVar
_) -> (Bag e
xs Bag e -> Bag e -> Bag e
forall a. Monoid a => a -> a -> a
`mappend` Bag e
ys, Subst
k, TyVar
i)) (\(Bag e
_,Subst
k,TyVar
_) (Bag e
_,Subst
l,TyVar
_) -> Subst
k Subst -> Subst -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Subst
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 :: * -> *) e.
(Search m, Expression e) =>
TyVar -> PriorSubsts m [e] -> m ([e], Subst, TyVar)
fps TyVar
mxty PriorSubsts m (Bag e)
ps
fps :: (Search m, Expression e) => TyVar -> PriorSubsts m [e] -> m ([e],[(TyVar, Type)],TyVar)
fps :: TyVar -> PriorSubsts m [e] -> m ([e], Subst, TyVar)
fps TyVar
mxty (PS Subst -> TyVar -> m ([e], Subst, TyVar)
f) = do
                     ([e]
es, Subst
sub, TyVar
m) <- Subst -> TyVar -> m ([e], Subst, TyVar)
f Subst
forall a. [a]
emptySubst (TyVar
mxtyTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1)
                     Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [e] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [e]
es Int -> Bool -> Bool
`seq` [e] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
es
                     ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return ([e]
es, Subst -> TyVar -> Subst
filterSubst Subst
sub TyVar
mxty, TyVar
m)
    where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]
          filterSubst :: Subst -> TyVar -> Subst
filterSubst Subst
sub  TyVar
mx = [ (TyVar, Type)
t | t :: (TyVar, Type)
t@(TyVar
i,Type
_) <- Subst
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.


type Generator m e = MemoDeb e -> Type -> PriorSubsts m [e]


mguPrograms, mguFuns :: (Search m, Expression e) => Generator m e
mguPrograms :: Generator m e
mguPrograms MemoDeb e
memodeb Type
ty = do Subst
subst <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                            Generator m e -> Generator m e
forall (m :: * -> *) e.
(Search m, Expression e) =>
Generator m e -> Generator m e
lookupFunsPoly Generator m e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguFuns MemoDeb e
memodeb (Subst -> Type -> Type
apply Subst
subst Type
ty)
mguFuns :: Generator m e
mguFuns MemoDeb e
memodeb = Generator m e -> Generator m e
forall (m :: * -> *) e.
(Search m, Expression e) =>
Generator m e -> Generator m e
generateFuns  Generator m e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguPrograms MemoDeb e
memodeb

-- MemoDebの型が違うと使えない．
generateFuns :: (Search m, Expression e) =>
                Generator m e                            -- ^ recursive call
                -> Generator m e
generateFuns :: Generator m e -> Generator m e
generateFuns Generator m e
rec memodeb :: MemoDeb e
memodeb@(MemoTrie e
_mt, [[Prim]]
primmono,Common
cmn) Type
reqret
    = let clbehalf :: a
clbehalf  = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"generateFuns: cannot happen."
          behalf :: Type -> PriorSubsts m [e]
behalf    = Generator m e
rec MemoDeb e
memodeb
          lltbehalf :: a
lltbehalf = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"generateFuns: cannot happen."
          lenavails :: Int
lenavails = Int
0
      in (Prim -> PriorSubsts m [e]) -> [[Prim]] -> PriorSubsts m [e]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum (Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> Prim
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> Prim
-> PriorSubsts m [e]
retPrimMono Common
cmn Int
lenavails Type -> PriorSubsts m [e]
forall a. a
clbehalf Type -> PriorSubsts m [e]
forall a. a
lltbehalf Type -> PriorSubsts m [e]
behalf Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret) [[Prim]]
primmono

\end{code}