-- 
-- (c) Susumu Katayama
--

\begin{code}
{-# LANGUAGE CPP, RelaxedPolyRec, FlexibleInstances #-}
module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF(..), freezePS, funApSub_, funApSub_spec, lookupNormalized, tokoro10fst, mkTrieOptSFIO) where
import MagicHaskeller.Types
import MagicHaskeller.TyConLib
import Control.Monad
import MagicHaskeller.CoreLang -- also imports unsafeShiftL/R for GHC<7.6 (which actually are shiftL/R respectively)
import Control.Monad.Search.Combinatorial
import MagicHaskeller.PriorSubsts
import Data.List(partition, sortBy, sort, nub, (\\))
import Data.Ix(inRange)

import MagicHaskeller.ClassifyDM

import MagicHaskeller.Instantiate

import MagicHaskeller.ProgramGenerator
import MagicHaskeller.ClassLib(mkCL, ClassLib(..), mguPrograms)
import MagicHaskeller.Options(Opt(..))

import MagicHaskeller.Expression

import Data.Monoid


import MagicHaskeller.T10(mergesortWithBy, diffSortedBy)

import qualified Data.Map as M

import MagicHaskeller.DebMT

import Data.Function(fix)
import System.IO(fixIO)
import System.IO.Unsafe(unsafeInterleaveIO)

import Data.Bits -- used for absence analysis
import Data.Word

import Data.Array

#if __GLASGOW_HASKELL__ >= 710
import Prelude hiding ((<$>))
#endif

import Debug.Trace
-- trace str = id

reorganize_ :: ([a] -> t) -> [a] -> t
reorganize_ [a] -> t
f [a]
av = [a] -> t
f ([a] -> t) -> [a] -> t
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> (a -> a -> Ordering) -> [a] -> [a]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy a -> a -> a
forall a b. a -> b -> a
const a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [a]
av
--reorganize_' = id

--reorganizer' = reorganize'
reorganizer' :: a -> a
reorganizer' = a -> a
forall a. a -> a
id

reorganizerId' :: (Functor m, Expression e) => ([Type] -> m e) -> [Type] -> m e
reorganizerId' :: ([Type] -> m e) -> [Type] -> m e
reorganizerId' = ([Type] -> m e) -> [Type] -> m e
forall e (m :: * -> *).
(Expression e, Functor m) =>
([Type] -> m e) -> [Type] -> m e
reorganizeId'
--reorganizerId' = id

classify :: Bool
classify = Bool
True
traceExpTy :: p -> a -> a
traceExpTy p
_ = a -> a
forall a. a -> a
id
-- traceExpTy fty = trace ("lookupexp "++ show fty)
traceTy :: p -> a -> a
traceTy p
_    = a -> a
forall a. a -> a
id
-- traceTy fty = trace ("lookup "++ show fty)

-- Memoization table, created from primitive components
--type ProgGenSF = PGSF AnnExpr
type ProgGenSF = PGSF CoreExpr -- temporarily, until reorganize for ProgGenSF is implemented.
data PGSF e = PGSF (MemoDeb e) TypeTrie (ExpTrie e) -- internal data representation.
-- ^ Program generator with synergetic filtration.
--   This program generator employs filtration by random testing, and rarely generate semantically equivalent expressions more than once, while different expressions will eventually appear (for most of the types, represented with Prelude types, whose arguments are instance of Arbitrary and which return instance of Ord).
--   The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree.
--   (Thus, adoption of expressions that may be equivalent to another already-generated-expression will be postponed until their \"uniqueness\" is proved.)
--   As a result, (unlike "ProgGen",) expressions with size N may not appear at depth N but some deeper place.
--
--   "ProgGenSF" is more efficient along with a middle-sized primitive set (like @reallyall@ found in LibTH.hs),
--   but is slower than "ProgGen" for a small-sized one.
--
--   Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault....

type ExpTip   e = Matrix e

type ExpTrie  e = MapType (ExpTip e)
type TypeTrie   = MapType (Matrix (Type, Subst, TyVar))

lmt :: Expression e => ExpTrie e -> Type -> Matrix e
lmt :: ExpTrie e -> Type -> Matrix e
lmt ExpTrie e
mt Type
fty = Type -> Matrix e -> Matrix e
forall p a. p -> a -> a
traceExpTy Type
fty (Matrix e -> Matrix e) -> Matrix e -> Matrix e
forall a b. (a -> b) -> a -> b
$
                                     ExpTrie e -> Type -> Matrix e
forall a. MapType a -> Type -> a
lookupMT ExpTrie e
mt Type
fty -- こっちだとlookup
--                                   filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty --  こっちだとrecompute

filtBF :: Expression e => Common -> Type -> Recomp e -> Matrix e
--          filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate
--filtBF cmn ty = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty)  .  mapDepthDB uniqSorter -- . mondepth
filtBF :: Common -> Type -> Recomp e -> Matrix e
filtBF Common
cmn Type
ty | Bool
classify  = DBound e -> Matrix e
forall a. Ord a => DBound a -> Matrix a
dbToCumulativeMx (DBound e -> Matrix e)
-> (Recomp e -> DBound e) -> Recomp e -> Matrix e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnExpr -> e) -> DBound AnnExpr -> DBound e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> e
forall e. Expression e => AnnExpr -> e
fromAnnExpr (DBound AnnExpr -> DBound e)
-> (Recomp e -> DBound AnnExpr) -> Recomp e -> DBound e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Common -> Type -> DBound AnnExpr -> DBound AnnExpr
fDM Common
cmn Type
ty (DBound AnnExpr -> DBound AnnExpr)
-> (Recomp e -> DBound AnnExpr) -> Recomp e -> DBound AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> AnnExpr) -> DBound e -> DBound AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWind (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)) Type
ty) (DBound e -> DBound AnnExpr)
-> (Recomp e -> DBound e) -> Recomp e -> DBound AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recomp e -> DBound e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> DBound e)
-> (Recomp e -> Recomp e) -> Recomp e -> DBound e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort
              | Bool
otherwise = Recomp e -> Matrix e
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp e -> Matrix e)
-> (Recomp e -> Recomp e) -> Recomp e -> Matrix e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort
fDM :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr
fDM = Common -> Type -> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *).
DB m =>
Common -> Type -> m AnnExpr -> m AnnExpr
filterDM -- こっちが従来
-- fDM = filterDMlite -- depth bound(つまり，Int->[(a,Int)]における引数のInt)の代わりに，depth boundからの距離(つまり，Int->[(a,Int)]におけるInt->[(a,ここのInt)])を使ってnrndsの何番目かを決めるもの．
                      -- filterDMと違って，同じdepth boundでも違う乱数を使うので，filterList同様depthを跨いだfiltrationができず，結果はいまいち．
                      -- ただし，dynamicな関数自体をメモ化すれば，格段にメモにヒットしやすくなるはず．

filtBFIO :: Expression e => Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO :: Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO Common
cmn Type
ty Recomp e
rc | Bool
classify  = DBoundT IO e -> IO (Matrix e)
forall a. Ord a => DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx (DBoundT IO e -> IO (Matrix e)) -> DBoundT IO e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ (AnnExpr -> e) -> DBoundT IO AnnExpr -> DBoundT IO e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> e
forall e. Expression e => AnnExpr -> e
fromAnnExpr (DBoundT IO AnnExpr -> DBoundT IO e)
-> DBoundT IO AnnExpr -> DBoundT IO e
forall a b. (a -> b) -> a -> b
$ Common -> Type -> DBound AnnExpr -> DBoundT IO AnnExpr
filterDMIO Common
cmn Type
ty (DBound AnnExpr -> DBoundT IO AnnExpr)
-> DBound AnnExpr -> DBoundT IO AnnExpr
forall a b. (a -> b) -> a -> b
$ (e -> AnnExpr) -> DBound e -> DBound AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWind (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)) Type
ty) (DBound e -> DBound AnnExpr) -> DBound e -> DBound AnnExpr
forall a b. (a -> b) -> a -> b
$ Recomp e -> DBound e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> DBound e) -> Recomp e -> DBound e
forall a b. (a -> b) -> a -> b
$ (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort Recomp e
rc
                   | Bool
otherwise = Matrix e -> IO (Matrix e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matrix e -> IO (Matrix e)) -> Matrix e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ Recomp e -> Matrix e
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp e -> Matrix e) -> Recomp e -> Matrix e
forall a b. (a -> b) -> a -> b
$ (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort Recomp e
rc

lmtty :: MapType a -> Type -> a
lmtty 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

--memocond i = 3<i
-- memocond i = i<10
memocond :: p -> Bool
memocond p
i = Bool
True

-- memocond ty = size ty < 10 -- popArgs avail tしてからやるのはちょっと無駄．と思ったけど，実際は関係ないみたい．
-- memocond av ty = size ty + sum (map size av) < 10


instance (Expression e) => ProgramGenerator (PGSF e) where
    mkTrieOpt :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOpt = Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
forall e.
Expression e =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOptSF
    matchingProgramsWOAbsents :: Type -> PGSF e -> m AnnExpr
matchingProgramsWOAbsents Type
ty (PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
etrie)    = Matrix AnnExpr -> m AnnExpr
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (Matrix AnnExpr -> m AnnExpr) -> Matrix AnnExpr -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ (Int -> Bag AnnExpr -> Bag AnnExpr)
-> Matrix AnnExpr -> Matrix AnnExpr
forall a b. (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b
zipDepthMx (\Int
i Bag AnnExpr
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Type -> Int
forall i. Integral i => Type -> i
getArity Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag AnnExpr
es) (Matrix AnnExpr -> Matrix AnnExpr)
-> Matrix AnnExpr -> Matrix AnnExpr
forall a b. (a -> b) -> a -> b
$ Common -> ExpTrie e -> Type -> Matrix AnnExpr
forall e.
Expression e =>
Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs Common
cmn ExpTrie e
etrie Type
ty    -- absents ga nai baai
    matchingPrograms :: Type -> PGSF e -> m AnnExpr
matchingPrograms Type
ty pgsf :: PGSF e
pgsf@(PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_) = Recomp AnnExpr -> m AnnExpr
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp AnnExpr -> m AnnExpr) -> Recomp AnnExpr -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ (e -> AnnExpr) -> Recomp e -> Recomp AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWindWind (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Type
ty) (Recomp e -> Recomp AnnExpr) -> Recomp e -> Recomp AnnExpr
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall (m :: * -> *) e.
(Search m, Expression e) =>
PGSF e -> Type -> m e
lookupWithAbsents PGSF e
pgsf Type
ty     -- absents mo fukumeru baai
    unifyingPrograms :: Type -> PGSF e -> m AnnExpr
unifyingPrograms Type
ty pgsf :: PGSF e
pgsf@(PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_) = m (Bag AnnExpr) -> m AnnExpr
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (m (Bag AnnExpr) -> m AnnExpr) -> m (Bag AnnExpr) -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ Recomp (Bag AnnExpr) -> m (Bag AnnExpr)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (Bag AnnExpr) -> m (Bag AnnExpr))
-> Recomp (Bag AnnExpr) -> m (Bag AnnExpr)
forall a b. (a -> b) -> a -> b
$ ((([e], BitSet), Subst, TyVar) -> Bag AnnExpr)
-> Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (([e]
es,BitSet
_),Subst
_,TyVar
_) -> (e -> AnnExpr) -> [e] -> Bag AnnExpr
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr ((CoreExpr -> Dynamic) -> e -> AnnExpr)
-> (CoreExpr -> Dynamic) -> e -> AnnExpr
forall a b. (a -> b) -> a -> b
$ Common -> CoreExpr -> Dynamic
reducer Common
cmn) [e]
es) (Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr))
-> Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr)
forall a b. (a -> b) -> a -> b
$ Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
forall e.
Expression e =>
Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
unifyingPossibilities Type
ty PGSF e
pgsf
instance Expression e => WithCommon (PGSF e) where
    extractCommon :: PGSF e -> Common
extractCommon    (PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_)      = Common
cmn

unifyingPossibilities :: Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
unifyingPossibilities Type
ty PGSF e
memodeb = PriorSubsts Recomp ([e], BitSet)
-> Subst -> TyVar -> Recomp (([e], BitSet), Subst, TyVar)
forall (m :: * -> *) a.
PriorSubsts m a -> Subst -> TyVar -> m (a, Subst, TyVar)
unPS (Generator Recomp e
forall e. Expression e => Generator Recomp e
unifyableExprs PGSF e
memodeb [] Type
ty) Subst
forall a. [a]
emptySubst TyVar
0

matchProgs :: Expression e => Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs :: Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs Common
cmn ExpTrie e
etrie Type
ty = (e -> AnnExpr) -> Matrix e -> Matrix AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWindWind (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Type
ty) (Matrix e -> Matrix AnnExpr) -> Matrix e -> Matrix AnnExpr
forall a b. (a -> b) -> a -> b
$ ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie Type
ty -- こっちだとlookup
{-
matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty)                 -- こっちだとrecompute というと語弊がある．recomputeしたきゃlmtのところを変えるべし．

-- matchProgsのみの下請け，matchFunsと交換可能
lookupFuns :: (Expression e, Ord e) => MemoDeb e -> [Type] -> Type -> BF e
lookupFuns memodeb@((_,mt),_,tcl,rtrie) avail reqret =
{-
#ifdef CLASSIFY
                                  fmap fromAnnExpr $ toRc $ filterDM tcl rtrie ty $ fromRc $ fmap (toAnnExprWind ty) $
#endif
-}
--                                  mapDepth uniqSort $
                                             matchFuns memodeb avail reqret
    where ty = popArgs avail reqret
-}

specializedPossibleTypes :: Type -> MemoDeb CoreExpr -> TypeTrie -> Recomp Type
specializedPossibleTypes :: Type -> MemoDeb CoreExpr -> TypeTrie -> Recomp Type
specializedPossibleTypes Type
ty MemoDeb CoreExpr
memodeb TypeTrie
ttrie = PriorSubsts Recomp Type -> Recomp Type
forall (m :: * -> *) a. Monad m => PriorSubsts m a -> m a
runPS ((([Type], Type) -> Type)
-> PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([Type]
av,Type
t) -> [Type] -> Type -> Type
popArgs [Type]
av Type
t) (PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type)
-> PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type
forall a b. (a -> b) -> a -> b
$ MemoDeb CoreExpr
-> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ([Type], Type)
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type], Type)
specializedTypes MemoDeb CoreExpr
memodeb TypeTrie
ttrie [] Type
ty)
-- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty


type MemoDeb e = (ClassLib e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common)

mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> PGSF e
mkTrieOptSF :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOptSF Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
txsopt [[Typed [CoreExpr]]]
txs
    = (PGSF e -> PGSF e) -> PGSF e
forall a. (a -> a) -> a
fix ((PGSF e -> PGSF e) -> PGSF e) -> (PGSF e -> PGSF e) -> PGSF e
forall a b. (a -> b) -> a -> b
$ \PGSF e
pgsf -> MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
forall e. MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
PGSF MemoDeb e
memoDeb TypeTrie
typeTrie (ExpTrie e -> PGSF e) -> ExpTrie e -> PGSF e
forall a b. (a -> b) -> a -> b
$ TyConLib -> (Type -> Matrix e) -> ExpTrie e
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTexp (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Common -> Type -> Recomp e -> Matrix e
forall e. Expression e => Common -> Type -> Recomp e -> Matrix e
filtBF Common
cmn Type
ty (Recomp e -> Matrix e) -> Recomp e -> Matrix e
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall e. Expression e => PGSF e -> Type -> Recomp e
matchFunctions PGSF e
pgsf Type
ty)
    where qtlopt :: ([[Prim]], [[Prim]])
qtlopt = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txsopt
          qtl :: ([[Prim]], [[Prim]])
qtl    = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txs
          memoDeb :: MemoDeb e
memoDeb  = (Common -> [Typed [CoreExpr]] -> ClassLib e
forall e.
Expression e =>
Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL Common
cmn [Typed [CoreExpr]]
classes, (([[Prim]], [[Prim]])
qtlopt,([[Prim]], [[Prim]])
qtl), Common
cmn)
          typeTrie :: TypeTrie
typeTrie = TyConLib -> (Type -> Matrix (Type, Subst, TyVar)) -> TypeTrie
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTty (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty (MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memoDeb TypeTrie
typeTrie Type
ty))
dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a
dbToCumulativeMx :: DBound a -> Matrix a
dbToCumulativeMx (DB Int -> Bag (a, Int)
f) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag a) -> Matrix a) -> Stream (Bag a) -> Matrix a
forall a b. (a -> b) -> a -> b
$ case (Int -> Bag a) -> [Int] -> Stream (Bag a)
forall a b. (a -> b) -> [a] -> [b]
map (Bag a -> Bag a
forall a. Ord a => [a] -> [a]
sort (Bag a -> Bag a) -> (Int -> Bag a) -> Int -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> a) -> Bag (a, Int) -> Bag a
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst (Bag (a, Int) -> Bag a) -> (Int -> Bag (a, Int)) -> Int -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bag (a, Int)
f) [Int
0..] of
                                 Stream (Bag a)
xss -> let result :: Stream (Bag a)
result = (Bag a -> Bag a -> Bag a)
-> Stream (Bag a) -> Stream (Bag a) -> Stream (Bag a)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> a -> Ordering) -> Bag a -> Bag a -> Bag a
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) Stream (Bag a)
xss (Stream (Bag a) -> Stream (Bag a))
-> Stream (Bag a) -> Stream (Bag a)
forall a b. (a -> b) -> a -> b
$ (Bag a -> Bag a -> Bag a)
-> Bag a -> Stream (Bag a) -> Stream (Bag a)
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Bag a -> Bag a -> Bag a
forall a. [a] -> [a] -> [a]
(++) [] Stream (Bag a)
result in Stream (Bag a)
result -- 多分本当は明示的にlookupし直すべき．
{- The following does not accurately give other chances to the expressions once dropped. コードをいじっているうちにいつの間にか最初の設計を忘れてこんなんなってた．
-- dbToCumulativeMx (DB f) = Mx $ map (map fst . f) [0..]
dbToCumulativeMx (DB f) = let foo = map (sort . map fst . f) [0..]
                          in Mx $ zipWith (diffSortedBy compare) foo ([]:foo)
--                          in Mx $ zipWith (\\) foo ([]:foo)
-}
mkTrieOptSFIO :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF e)
mkTrieOptSFIO :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO (PGSF e)
mkTrieOptSFIO Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
txsopt [[Typed [CoreExpr]]]
txs
    = (PGSF e -> IO (PGSF e)) -> IO (PGSF e)
forall a. (a -> IO a) -> IO a
fixIO ((PGSF e -> IO (PGSF e)) -> IO (PGSF e))
-> (PGSF e -> IO (PGSF e)) -> IO (PGSF e)
forall a b. (a -> b) -> a -> b
$ \PGSF e
pgsf -> (ExpTrie e -> PGSF e) -> IO (ExpTrie e) -> IO (PGSF e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
forall e. MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
PGSF MemoDeb e
memoDeb TypeTrie
typeTrie) (IO (ExpTrie e) -> IO (PGSF e)) -> IO (ExpTrie e) -> IO (PGSF e)
forall a b. (a -> b) -> a -> b
$ TyConLib -> (Type -> IO (Matrix e)) -> IO (ExpTrie e)
forall a. TyConLib -> (Type -> IO a) -> IO (MapType a)
mkMTIO (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Common -> Type -> Recomp e -> IO (Matrix e)
forall e.
Expression e =>
Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO Common
cmn Type
ty (Recomp e -> IO (Matrix e)) -> Recomp e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall e. Expression e => PGSF e -> Type -> Recomp e
matchFunctions PGSF e
pgsf Type
ty)
    where qtlopt :: ([[Prim]], [[Prim]])
qtlopt = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txsopt
          qtl :: ([[Prim]], [[Prim]])
qtl    = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txs
          memoDeb :: MemoDeb e
memoDeb  = (Common -> [Typed [CoreExpr]] -> ClassLib e
forall e.
Expression e =>
Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL Common
cmn [Typed [CoreExpr]]
classes, (([[Prim]], [[Prim]])
qtlopt,([[Prim]], [[Prim]])
qtl), Common
cmn)
          typeTrie :: TypeTrie
typeTrie = TyConLib -> (Type -> Matrix (Type, Subst, TyVar)) -> TypeTrie
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTty (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty (MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memoDeb TypeTrie
typeTrie Type
ty))
dbtToCumulativeMx :: (Ord a) => DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx :: DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx (DBT Int -> IO (Bag (a, Int))
f) = do [Bag (a, Int)]
ts <- [IO (Bag (a, Int))] -> IO [Bag (a, Int)]
forall a. [IO a] -> IO [a]
interleaveActions ([IO (Bag (a, Int))] -> IO [Bag (a, Int)])
-> [IO (Bag (a, Int))] -> IO [Bag (a, Int)]
forall a b. (a -> b) -> a -> b
$ (Int -> IO (Bag (a, Int))) -> [Int] -> [IO (Bag (a, Int))]
forall a b. (a -> b) -> [a] -> [b]
map Int -> IO (Bag (a, Int))
f [Int
0..]
                               let xss :: [[a]]
xss = (Bag (a, Int) -> [a]) -> [Bag (a, Int)] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]) -> (Bag (a, Int) -> [a]) -> Bag (a, Int) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> a) -> Bag (a, Int) -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst) [Bag (a, Int)]
ts
                               let result :: [[a]]
result = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> a -> Ordering) -> [a] -> [a] -> [a]
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [[a]]
xss ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [[a]]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [] [[a]]
result 
                               Matrix a -> IO (Matrix a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matrix a -> IO (Matrix a)) -> Matrix a -> IO (Matrix a)
forall a b. (a -> b) -> a -> b
$ [[a]] -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx [[a]]
result -- 多分本当は明示的にlookupし直すべき．

mkMTty :: TyConLib -> (Type -> a) -> MapType a
mkMTty = TyConLib -> (Type -> a) -> MapType a
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT
mkMTexp :: TyConLib -> (Type -> a) -> MapType a
mkMTexp = TyConLib -> (Type -> a) -> MapType a
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT

mondepth :: Recomp b -> Recomp b
mondepth = (Int -> Bag b -> Bag b) -> Recomp b -> Recomp b
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
d Bag b
xs -> String -> Bag b -> Bag b
forall a. String -> a -> a
trace (String
"depth="String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
dString -> String -> String
forall a. [a] -> [a] -> [a]
++String
", and the length is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (Bag b -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Bag b
xs)) Bag b
xs) -- depthと表示するなら+1するべきであった．(0から始まるので)


type BFT = Recomp
unBFM :: Matrix a -> Stream (Bag a)
unBFM = Matrix a -> Stream (Bag a)
forall a. Matrix a -> Stream (Bag a)
unMx


{-
freezePS :: (Search m, Expression e) => Type -> PriorSubsts m (ExpTip e) -> Matrix (ExpTip e,Subst,Int)
freezePS ty ps
    = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)
      in Mx $ map (tokoro10ap ty) $ scanl1 (++) $ unMx $ toMx $ unPS ps emptySubst (mxty+1)
-}
freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type,Subst,TyVar)
freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty PriorSubsts Recomp Type
ps
    = let mxty :: TyVar
mxty = Type -> TyVar
maxVarID Type
ty -- `max` maximum (map maxVarID avail)
--      in zipDepthMx (\d tups -> map (\(Mx xss, s, i)->(xss!!d, s, i)) $ tokoro10ap ty tups) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1)
      in (Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar))
-> Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar)
forall s i. [(Type, s, i)] -> [(Type, s, i)]
tokoro10ap (Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar))
-> Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (((Type, Subst, TyVar), Int) -> (Type, Subst, TyVar))
-> Recomp ((Type, Subst, TyVar), Int)
-> Recomp (Type, Subst, TyVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type, Subst, TyVar), Int) -> (Type, Subst, TyVar)
forall a b. (a, b) -> a
fst (Recomp ((Type, Subst, TyVar), Int) -> Recomp (Type, Subst, TyVar))
-> Recomp ((Type, Subst, TyVar), Int)
-> Recomp (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag ((Type, Subst, TyVar), Int))
-> Recomp ((Type, Subst, TyVar), Int)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag ((Type, Subst, TyVar), Int))
 -> Recomp ((Type, Subst, TyVar), Int))
-> (Int -> Bag ((Type, Subst, TyVar), Int))
-> Recomp ((Type, Subst, TyVar), Int)
forall a b. (a -> b) -> a -> b
$ DBound (Type, Subst, TyVar)
-> Int -> Bag ((Type, Subst, TyVar), Int)
forall a. DBound a -> Int -> Bag (a, Int)
unDB (DBound (Type, Subst, TyVar)
 -> Int -> Bag ((Type, Subst, TyVar), Int))
-> DBound (Type, Subst, TyVar)
-> Int
-> Bag ((Type, Subst, TyVar), Int)
forall a b. (a -> b) -> a -> b
$ Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ PriorSubsts Recomp Type
-> Subst -> TyVar -> Recomp (Type, Subst, TyVar)
forall (m :: * -> *) a.
PriorSubsts m a -> Subst -> TyVar -> m (a, Subst, TyVar)
unPS PriorSubsts Recomp Type
ps Subst
forall a. [a]
emptySubst (TyVar
mxtyTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) 
  --  tokoro10 in place of tokoro10ap ty causes an infinite loop.
  --  fps mxty ps can be used in place of unPS ps emptySubst (mxty+1)

-- MemoStingy.tokoro10 is different from T10.tokoro10, in that duplicates will be removed.
-- (Note that the type can be specialized to [(Type,k,i)] -> [(Type,k,i)])
tokoro10 :: (Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]
tokoro10 :: [(a, k, i)] -> [(a, k, i)]
tokoro10 = ((a, k, i) -> (a, k, i) -> (a, k, i))
-> ((a, k, i) -> (a, k, i) -> Ordering)
-> [(a, k, i)]
-> [(a, k, i)]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (a, k, i) -> (a, k, i) -> (a, k, i)
forall a b. a -> b -> a
const (\ (a
_,k
k,i
_) (a
_,k
l,i
_) -> k
k k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` k
l)

-- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l)

tokoro10ap :: [(Type,s,i)] -> [(Type,s,i)]
-- tokoro10ap = mergesortWithBy const (\ (t,_,_) (u,_,_) -> compare t u)
tokoro10ap :: [(Type, s, i)] -> [(Type, s, i)]
tokoro10ap = Map Type (Type, s, i) -> [(Type, s, i)]
forall k a. Map k a -> [a]
M.elems (Map Type (Type, s, i) -> [(Type, s, i)])
-> ([(Type, s, i)] -> Map Type (Type, s, i))
-> [(Type, s, i)]
-> [(Type, s, i)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, s, i) -> (Type, s, i) -> (Type, s, i))
-> [(Type, (Type, s, i))] -> Map Type (Type, s, i)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (Type, s, i) -> (Type, s, i) -> (Type, s, i)
forall a b. a -> b -> a
const ([(Type, (Type, s, i))] -> Map Type (Type, s, i))
-> ([(Type, s, i)] -> [(Type, (Type, s, i))])
-> [(Type, s, i)]
-> Map Type (Type, s, i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, s, i) -> (Type, (Type, s, i)))
-> [(Type, s, i)] -> [(Type, (Type, s, i))]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: (Type, s, i)
t@(Type
ty,s
_,i
_) -> ( {- normalize -} Type
ty, (Type, s, i)
t))

-- availにしろTypeにしろapplyされている．
-- だからこそ，runAnotherPS的にemptySubstに対して実行した方が効率的なはず？ でも，Substitutionってそんなにでかくならなかったのでは？FiniteMapでもassoc listでも変わらなかった気が．



fps :: Search m => 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
exprs, 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)
                     (e, Subst, TyVar) -> m (e, Subst, TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (e
exprs, 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.




specializedTypes :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type],Type)
specializedTypes :: MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type], Type)
specializedTypes MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t = do BitSet
_ <- MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t
                                            Subst
subst <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                                            ([Type], Type) -> PriorSubsts m ([Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Type -> Type
apply Subst
subst) [Type]
avail, Subst -> Type -> Type
apply Subst
subst Type
t)
-- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth.
specializedCases, specCases :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie = ([Type] -> Type -> PriorSubsts m BitSet)
-> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo (MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie)
-- specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail)
specCases :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail (Type
t0:->Type
t1) = (BitSet -> BitSet) -> PriorSubsts m BitSet -> PriorSubsts m BitSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) (PriorSubsts m BitSet -> PriorSubsts m BitSet)
-> PriorSubsts m BitSet -> PriorSubsts m BitSet
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie (Type
t0 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
avail) Type
t1
specCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
reqret    = ([Type] -> PriorSubsts m BitSet) -> [Type] -> PriorSubsts m BitSet
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
newavail -> MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
uniExprs_ MemoDeb e
memodeb TypeTrie
ttrie [Type]
newavail Type
reqret) [Type]
avail





uniExprs_ :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
{-
uniExprs_ memodeb avail t
    = convertPS fromRc $ psListToPSRecomp lfp
    where lfp depth
              | memocond depth     = lookupUniExprs memodeb avail t depth
              | otherwise          = makeUniExprs memodeb avail t depth >> return ()
-}
uniExprs_ :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
uniExprs_ MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t
    = (Matrix (BitSet, Subst, TyVar) -> m (BitSet, Subst, TyVar))
-> PriorSubsts Matrix BitSet -> PriorSubsts m BitSet
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS Matrix (BitSet, Subst, TyVar) -> m (BitSet, Subst, TyVar)
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (PriorSubsts Matrix BitSet -> PriorSubsts m BitSet)
-> PriorSubsts Matrix BitSet -> PriorSubsts m BitSet
forall a b. (a -> b) -> a -> b
$ (BitSet -> Type -> BitSet)
-> (Type -> Recomp (Type, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts Matrix BitSet
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
(BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedSharedBits (\BitSet
ixs Type
_ -> BitSet
ixs) (MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie MemoDeb e
memodeb TypeTrie
ttrie) [Type]
avail Type
t

{-
lookupUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] ()
lookupUniExprs memodeb@(_,(mt,_),_,_) avail t depth
    = fmap (const ()) $ lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t

makeUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type
makeUniExprs memodeb avail t depth
    = convertPS tokoro10fst $
                do psRecompToPSList (reorganize_' (\av -> specCases' memodeb av t) avail) depth
                   sub   <- getSubst
                   return $ quantify (apply sub $ popArgs avail t)
-}

lookupReorganized :: ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
md Type
typ = let ([Type]
avs, Type
retty) = Type -> ([Type], Type)
splitArgs (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Type -> Type
normalize Type
typ
                           in ([Type] -> Matrix e) -> [Type] -> Matrix e
forall (m :: * -> *) e.
(Functor m, Expression e) =>
([Type] -> m e) -> [Type] -> m e
reorganizerId' (\[Type]
av -> ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lmt ExpTrie e
md (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
popArgs [Type]
av Type
retty) [Type]
avs

-- entry point for memoization
specTypes :: Expression e => MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes :: MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
ty
                           = let ([Type]
avail,Type
t) = Type -> ([Type], Type)
splitArgs Type
ty
                             in (Recomp (Type, Subst, TyVar) -> Recomp (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> PriorSubsts Recomp Type
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> Recomp (Type, Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag (Type, Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag (Type, Subst, TyVar)
es)) (PriorSubsts Recomp Type -> PriorSubsts Recomp Type)
-> PriorSubsts Recomp Type -> PriorSubsts Recomp Type
forall a b. (a -> b) -> a -> b
$ do
                                ([Type] -> PriorSubsts Recomp ())
-> [Type] -> PriorSubsts Recomp ()
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
av -> MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
specCases' MemoDeb e
memodeb TypeTrie
ttrie [Type]
av Type
t) [Type]
avail
-- quantifyはmemo先で既にやられているので不要
                                Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
ty

#ifdef SEMIGROUP
instance Semigroup BitSet where
    <> :: BitSet -> BitSet -> BitSet
(<>) = BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.)
#endif
instance Monoid BitSet where
    mappend :: BitSet -> BitSet -> BitSet
mappend = BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.)
    mempty :: BitSet
mempty  = BitSet
0

funApSub_ :: (Search m, Monoid a) => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m a) -> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_ :: (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:=>Type
ts) = do Type -> PriorSubsts m ()
clbehalf Type
t
                                                  (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:>Type
ts)  = (a -> a -> a)
-> PriorSubsts m a -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (Type -> PriorSubsts m a
lltbehalf Type
t) ((Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts)
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:->Type
ts) = (a -> a -> a)
-> PriorSubsts m a -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (Type -> PriorSubsts m a
behalf Type
t)    ((Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts)
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
_t       = a -> PriorSubsts m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty

funApSub_spec :: (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_spec Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
behalf = (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
behalf Type -> PriorSubsts m a
behalf

funApSub_forcingNil :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> PriorSubsts Recomp ()
funApSub_forcingNil :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
t BitSet
bsf 
  = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
t BitSet
bsf ((BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ())
-> (BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ \BitSet
bs -> Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
bs BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
funApSub_forcingNil_spec :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil_spec Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf Type -> PriorSubsts Recomp BitSet
behalf

funApSub_forcingNil_cont :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> (BitSet->PriorSubsts Recomp a) -> PriorSubsts Recomp a
funApSub_forcingNil_cont :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:=>Type
ts) BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do Type -> PriorSubsts Recomp ()
clbehalf Type
t
                                                                          (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
bsf BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:>Type
ts)  BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do BitSet
bse <- Type -> PriorSubsts Recomp BitSet
lltbehalf Type
t
                                                                          let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
                                                                          BitSet -> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp a -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall a b. (a -> b) -> a -> b
$
                                                                            (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
newRemaining BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:->Type
ts) BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do BitSet
bse <- Type -> PriorSubsts Recomp BitSet
behalf Type
t
                                                                          let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
                                                                          BitSet -> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp a -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall a b. (a -> b) -> a -> b
$
                                                                            (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
newRemaining BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
_t       BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = BitSet -> PriorSubsts Recomp a
cont BitSet
bsf

funApSub_forcingNil_cont_spec :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont_spec Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf Type -> PriorSubsts Recomp BitSet
behalf

mguAssumptionsBits :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits :: Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits  Type
patty [Type]
assumptions = ([Type] -> Type -> PriorSubsts m BitSet)
-> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(MonadPlus m, Bits a, Num a) =>
[Type] -> Type -> PriorSubsts m a
mguAssumptionsBits' [Type]
assumptions Type
patty
mguAssumptionsBits' :: [Type] -> Type -> PriorSubsts m a
mguAssumptionsBits' [Type]
assumptions Type
patty = [PriorSubsts m a] -> PriorSubsts m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m a] -> PriorSubsts m a)
-> [PriorSubsts m a] -> PriorSubsts m a
forall a b. (a -> b) -> a -> b
$ (Int -> Type -> PriorSubsts m a)
-> [Int] -> [Type] -> [PriorSubsts m a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n Type
t -> Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
patty Type
t PriorSubsts m () -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> PriorSubsts m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
n)) [Int
0..] [Type]
assumptions

specCases' :: Expression e => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
-- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen)
specCases' :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
specCases' memodeb :: MemoDeb e
memodeb@(CL MemoDeb e
classLib, (prims :: ([[Prim]], [[Prim]])
prims@([[Prim]]
primgen,[[Prim]]
primmono),([[Prim]], [[Prim]])
_),Common
cmn) TypeTrie
ttrie [Type]
avail Type
reqret
 = (Prim -> PriorSubsts Recomp ())
-> [[Prim]] -> PriorSubsts Recomp ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts Recomp ()
forall i a a.
Integral i =>
(a, i, Type, TyVar, Typed a) -> PriorSubsts Recomp ()
retPrimMono [[Prim]]
primmono PriorSubsts Recomp ()
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [PriorSubsts Recomp ()] -> PriorSubsts Recomp ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((BitSet -> Type -> PriorSubsts Recomp ())
-> [BitSet] -> [Type] -> [PriorSubsts Recomp ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BitSet -> Type -> PriorSubsts Recomp ()
retMono ((BitSet -> BitSet) -> BitSet -> [BitSet]
forall a. (a -> a) -> a -> [a]
iterate (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) BitSet
1) [Type]
avail) PriorSubsts Recomp ()
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Prim -> PriorSubsts Recomp ())
-> [[Prim]] -> PriorSubsts Recomp ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts Recomp ()
forall i a c a.
Integral i =>
(a, i, c, TyVar, Typed a) -> PriorSubsts Recomp ()
retGen [[Prim]]
primgen
    where fas :: Type -> PriorSubsts Recomp BitSet
fas | Opt () -> Bool
forall a. Opt a -> Bool
constrL (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> PriorSubsts Recomp BitSet
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *). MonadPlus m => Type -> PriorSubsts m BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf
              | Bool
otherwise         = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> PriorSubsts Recomp BitSet
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_spec      Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf
          fasf :: Type -> BitSet -> PriorSubsts Recomp ()
fasf| Opt () -> Bool
forall a. Opt a -> Bool
constrL (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *). MonadPlus m => Type -> PriorSubsts m BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf
              | Bool
otherwise         = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil_spec      Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf
          behalf :: Type -> PriorSubsts Recomp BitSet
behalf    = MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail
          lltbehalf :: Type -> PriorSubsts m BitSet
lltbehalf Type
ty = Type -> [Type] -> PriorSubsts m BitSet
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits Type
ty [Type]
avail
          clbehalf :: Type -> PriorSubsts m ()
clbehalf  Type
ty = Generator m e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguPrograms MemoDeb e
classLib Type
ty PriorSubsts m [e] -> PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> PriorSubsts m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          lenavails :: Int
lenavails = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail
          fullBits :: BitSet
fullBits  | Int
lenavails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 = BitSet
0
                    | Bool
otherwise      = (BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
lenavails) BitSet -> BitSet -> BitSet
forall a. Num a => a -> a -> a
- BitSet
1
          -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()
          retPrimMono :: (a, i, Type, TyVar, Typed a) -> PriorSubsts Recomp ()
retPrimMono (a
_, i
arity, Type
retty, TyVar
numtvs, a
_xs:::Type
ty)
                                              = i
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$
                                                do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
                                                   Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
retty)
                                                   Type -> BitSet -> PriorSubsts Recomp ()
fasf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) BitSet
fullBits
          -- retMono :: BitSet -> Type -> PriorSubsts BFT ()
          retMono :: BitSet -> Type -> PriorSubsts Recomp ()
retMono BitSet
ix Type
ty = Integer
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Type -> Integer
forall i. Integral i => Type -> i
getArity Type
ty) PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ do
                          Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret (Type -> Type
getRet Type
ty)
                          Type -> BitSet -> PriorSubsts Recomp ()
fasf Type
ty (BitSet -> PriorSubsts Recomp ())
-> BitSet -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
fullBits BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ix
          -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()
          retGen :: (a, i, c, TyVar, Typed a) -> PriorSubsts Recomp ()
retGen (a
_, i
arity, c
_r, TyVar
numtvs, a
_s:::Type
ty) = i
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$
                                             do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？
                                               --                                                              -- unitSubstをinlineにしないと駄目か
                                                Int -> TyVar -> Type -> PriorSubsts Recomp Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
                                                (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont_spec Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) BitSet
fullBits ((BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ())
-> (BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ \BitSet
i -> do
                                                  Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)

                                                  Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
orderedAndUsedArgs Type
gentvar)
                                                  Type -> BitSet -> PriorSubsts Recomp ()
fasf Type
gentvar BitSet
i

-- absentを含める場合こっちを使う
lookupWithAbsents :: (Search m, Expression e) => PGSF e -> Type -> m e
lookupWithAbsents :: PGSF e -> Type -> m e
lookupWithAbsents PGSF e
memodeb Type
ty
  = case Type -> ([Type], Type)
splitArgs Type
ty of 
    ([Type]
a,Type
r) -> (m e -> m e) -> ([Type] -> Type -> m e) -> [Type] -> Type -> m e
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind ((e -> e) -> m e -> m e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> CoreExpr) -> e -> e
forall e. Expression e => (CoreExpr -> CoreExpr) -> e -> e
mapCE CoreExpr -> CoreExpr
Lambda)) ((Type -> Recomp ([e], Subst, TyVar)) -> [Type] -> Type -> m e
forall (m :: * -> *) (n :: * -> *) e.
(Search m, Search n, Expression e) =>
(Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e
lookupNormalizedSharedET (PGSF e -> Type -> Recomp ([e], Subst, TyVar)
forall e.
Expression e =>
PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie PGSF e
memodeb)) [Type]
a Type
r
--unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb)))

lookupNormalizedSharedET :: (Search m, Search n, Expression e) => (Type -> m ([e], Subst, TyVar)) ->  [Type] -> Type -> n e
lookupNormalizedSharedET :: (Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e
lookupNormalizedSharedET Type -> m ([e], Subst, TyVar)
fun [Type]
avail Type
t
  = let annAvails :: Subst
annAvails = [TyVar] -> [Type] -> Subst
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar
0..] [Type]
avail
    in Recomp e -> n e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> n e) -> Recomp e -> n e
forall a b. (a -> b) -> a -> b
$ (Int -> [e]) -> Recomp e
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> [e]) -> Recomp e) -> (Int -> [e]) -> Recomp e
forall a b. (a -> b) -> a -> b
$ \Int
d -> [ Int -> [TyVar] -> e -> e
forall e. Expression e => Int -> [TyVar] -> e -> e
decodeVars ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail) [TyVar]
ixs e
e
                           | Subst
avs <- Int -> Subst -> [Subst]
forall t a. (Eq t, Num t) => t -> [a] -> [[a]]
combs (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Subst
annAvails
                           , let ([TyVar]
ixs, [Type]
newavails) = Subst -> ([TyVar], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip Subst
avs
                                 (Type
tn, Decoder
_decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
newt (Type -> TyVar
maxVarID Type
newt TyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+ TyVar
1)
                                 newt :: Type
newt = [Type] -> Type -> Type
popArgs [Type]
newavails Type
t
                           , ([e]
exprs, Subst
_, TyVar
_) <- Recomp ([e], Subst, TyVar) -> Int -> Bag ([e], Subst, TyVar)
forall a. Recomp a -> Int -> Bag a
unRc (m ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc (Type -> m ([e], Subst, TyVar)
fun Type
tn)) Int
d
                           , e
e <- [e]
exprs
                           ]

type Generator m e = PGSF e -> [Type] -> Type -> PriorSubsts m ([e], BitSet)

unifyableExprs ::  Expression e => Generator Recomp e
unifyableExprs :: Generator Recomp e
unifyableExprs PGSF e
memodeb
  = ([Type] -> Type -> PriorSubsts Recomp ([e], BitSet))
-> [Type] -> Type -> PriorSubsts Recomp ([e], BitSet)
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo ((PriorSubsts Recomp ([e], BitSet)
 -> PriorSubsts Recomp ([e], BitSet))
-> ([Type] -> Type -> PriorSubsts Recomp ([e], BitSet))
-> [Type]
-> Type
-> PriorSubsts Recomp ([e], BitSet)
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind ((([e], BitSet) -> ([e], BitSet))
-> PriorSubsts Recomp ([e], BitSet)
-> PriorSubsts Recomp ([e], BitSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ([e]
es, BitSet
bs) -> ((e -> e) -> [e] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> CoreExpr) -> e -> e
forall e. Expression e => (CoreExpr -> CoreExpr) -> e -> e
mapCE CoreExpr -> CoreExpr
Lambda) [e]
es, BitSet
bs BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1)))
                  (\[Type]
avail -> ([TyVar] -> BitSet -> [e] -> ([e], BitSet))
-> (Type -> Recomp ([e], Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts Recomp ([e], BitSet)
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared (\[TyVar]
ixs BitSet
ixBits [e]
e -> ((e -> e) -> [e] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [TyVar] -> e -> e
forall e. Expression e => Int -> [TyVar] -> e -> e
decodeVars ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail) [TyVar]
ixs) [e]
e, BitSet
ixBits)) (PGSF e -> Type -> Recomp ([e], Subst, TyVar)
forall e.
Expression e =>
PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie PGSF e
memodeb) [Type]
avail))
--unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb)))


-- memocondexp t d = 1<d && d<7
memocondexp :: Type -> a -> Bool
memocondexp Type
t a
d = Type -> Int
size Type
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 Bool -> Bool -> Bool
&& a
0a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
d Bool -> Bool -> Bool
&& a
da -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
7

lookupTypeTrie :: Expression e => MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie :: MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie memodeb :: MemoDeb e
memodeb@(ClassLib e
_, (([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_, Common
cmn) TypeTrie
ttrie Type
t
    = (Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar))
-> (Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d -> Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (if Opt () -> Type -> Int -> Bool
forall a. Opt a -> Type -> Int -> Bool
memoCondPure (Common -> Opt ()
opt Common
cmn) Type
t Int
d
                       then (Type -> Matrix (Type, Subst, TyVar))
-> Type -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
ttrie) Type
t
                       else Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
t (PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
t  ) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d -- if d<8 then d else 7
lookupTypeTrieAndExpTrie :: Expression e => PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie :: PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie (PGSF memodeb :: MemoDeb e
memodeb@(ClassLib e
_, (([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_, Common
cmn) TypeTrie
ttrie ExpTrie e
etrie) Type
t
  = (Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar))
-> (Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d -> if Opt () -> Type -> Int -> Bool
forall a. Opt a -> Type -> Int -> Bool
memoCondPure (Common -> Opt ()
opt Common
cmn) Type
t Int
d
                 then [ (Matrix e -> Stream [e]
forall a. Matrix a -> Stream (Bag a)
unMx (ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
apply Subst
s Type
t) Stream [e] -> Int -> [e]
forall a. [a] -> Int -> a
!! Int
d, Subst
s, TyVar
i)
                            | (Type
_ty, Subst
s, TyVar
i) <- Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx ((Type -> Matrix (Type, Subst, TyVar))
-> Type -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNormReorganized (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
ttrie) Type
t) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d {- if d<8 then d else 7 -} ]
                 else -- [ (unMx (filtBF cmn ty $ matchFunctions memodeb ty) !! d, s, i) -- exptrieも同様にmemoCondPureを使う場合．
                     [ (Matrix e -> Stream [e]
forall a. Matrix a -> Stream (Bag a)
unMx (ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
apply Subst
s Type
t) Stream [e] -> Int -> [e]
forall a. [a] -> Int -> a
!! Int
d, Subst
s, TyVar
i)  -- exptrieでは全部memoizeする場合．
                            | (Type
ty, Subst
s, TyVar
i) <- Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
t (PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
t) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d {- if d<8 then d else 7 -} ]

lookupNormReorganized :: (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNormReorganized Type -> m (e, Subst, TyVar)
fun Type
typ = let ([Type]
avs, Type
retty) = Type -> ([Type], Type)
splitArgs Type
typ
                               in ([Type] -> m (e, Subst, TyVar)) -> [Type] -> m (e, Subst, TyVar)
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
av -> (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm Type -> m (e, Subst, TyVar)
fun ([Type] -> Type -> Type
popArgs [Type]
av Type
retty)) [Type]
avs
lookupNorm :: MonadPlus m => (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm :: (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm = (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
forall a. a -> a
id
{-
lookupNorm fun typ
    = do let
             mx  = maxVarID typ + 1
             (tn, decoder) = encode typ mx
         (es, sub, m) <- fun tn
         return (es, retrieve decoder sub, mx+m)
-}


lookupNormalized :: (Functor m, MonadPlus m) => (Type -> m (e, Subst, TyVar)) ->  [Type] -> Type -> PriorSubsts m e
lookupNormalized :: (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e
lookupNormalized Type -> m (e, Subst, TyVar)
fun [Type]
avail Type
t
    = do TyVar
mx <- PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
getMx
         let typ :: Type
typ = [Type] -> Type -> Type
popArgs [Type]
avail Type
t
             (Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
typ TyVar
mx
         (e
es, Subst
sub, TyVar
m) <-  m (e, Subst, TyVar) -> PriorSubsts m (e, Subst, TyVar)
forall (m :: * -> *) a. Monad m => m a -> PriorSubsts m a
mkPS (Type -> m (e, Subst, TyVar)
fun Type
tn)
         Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (Decoder -> Subst -> Subst
retrieve Decoder
decoder Subst
sub)
         (TyVar -> TyVar) -> PriorSubsts m ()
forall (m :: * -> *).
Monad m =>
(TyVar -> TyVar) -> PriorSubsts m ()
updateMx (TyVar
mTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+)
         e -> PriorSubsts m e
forall (m :: * -> *) a. Monad m => a -> m a
return e
es
lookupNormalizedShared :: (Search m, Search n) => ([Int8] -> BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) ->  [Type] -> Type -> PriorSubsts n r
lookupNormalizedShared :: ([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared [TyVar] -> BitSet -> e -> r
ceDecoder Type -> m (e, Subst, TyVar)
fun [Type]
avail Type
t
    = let annAvails :: [(TyVar, BitSet, Type)]
annAvails = [TyVar] -> [BitSet] -> [Type] -> [(TyVar, BitSet, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [TyVar
0..] ((BitSet -> BitSet) -> BitSet -> [BitSet]
forall a. (a -> a) -> a -> [a]
iterate (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) BitSet
1) [Type]
avail
      in (Subst -> TyVar -> n (r, Subst, TyVar)) -> PriorSubsts n r
forall (m :: * -> *) a.
(Subst -> TyVar -> m (a, Subst, TyVar)) -> PriorSubsts m a
PS (\Subst
subst TyVar
mx -> Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar))
-> Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar))
-> (Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d ->[Bag (r, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 
                                             [ ((e, Subst, TyVar) -> (r, Subst, TyVar))
-> [(e, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall a b. (a -> b) -> [a] -> [b]
map (\ (e
exprs, Subst
sub, TyVar
m) -> ([TyVar] -> BitSet -> e -> r
ceDecoder [TyVar]
ixs BitSet
ixBits 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)) ([(e, Subst, TyVar)] -> Bag (r, Subst, TyVar))
-> [(e, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Recomp (e, Subst, TyVar) -> Int -> [(e, Subst, TyVar)]
forall a. Recomp a -> Int -> Bag a
unRc (m (e, Subst, TyVar) -> Recomp (e, Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc (Type -> m (e, Subst, TyVar)
fun Type
tn)) Int
d 
                                             | [(TyVar, BitSet, Type)]
annAvs <- Int -> [(TyVar, BitSet, Type)] -> [[(TyVar, BitSet, Type)]]
forall t a. (Eq t, Num t) => t -> [a] -> [[a]]
combs (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(TyVar, BitSet, Type)]
annAvails
                                             , let ([TyVar]
ixs, [BitSet]
ixBitss, [Type]
newavails) = [(TyVar, BitSet, Type)] -> ([TyVar], [BitSet], [Type])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(TyVar, BitSet, Type)]
annAvs 
                                                   ixBits :: BitSet
ixBits = (BitSet -> BitSet -> BitSet) -> BitSet -> [BitSet] -> BitSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.) BitSet
0 [BitSet]
ixBitss
                                                   (Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode ([Type] -> Type -> Type
popArgs [Type]
newavails Type
t) TyVar
mx
                                             ])

type BitSet = Word32
#if __GLASGOW_HASKELL__ < 706
countBits = countBits32
#else
countBits :: BitSet -> Int
countBits = BitSet -> Int
forall a. Bits a => a -> Int
popCount
#endif
-- Also, if BitSet = Integer, countBits32 should be used in place of popCount because popCount for Integers is inefficient.

lookupNormalizedSharedBits :: (Search m, Search n) => (BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) ->  [Type] -> Type -> PriorSubsts n r
lookupNormalizedSharedBits :: (BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedSharedBits BitSet -> e -> r
f = ([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared ((BitSet -> e -> r) -> [TyVar] -> BitSet -> e -> r
forall a b. a -> b -> a
const BitSet -> e -> r
f)


tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)]
-- tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l)
tokoro10fst :: [(k, s, i)] -> [(k, s, i)]
tokoro10fst = Map k (k, s, i) -> [(k, s, i)]
forall k a. Map k a -> [a]
M.elems (Map k (k, s, i) -> [(k, s, i)])
-> ([(k, s, i)] -> Map k (k, s, i)) -> [(k, s, i)] -> [(k, s, i)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, s, i) -> (k, s, i) -> (k, s, i))
-> [(k, (k, s, i))] -> Map k (k, s, i)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (k, s, i) -> (k, s, i) -> (k, s, i)
forall a b. a -> b -> a
const ([(k, (k, s, i))] -> Map k (k, s, i))
-> ([(k, s, i)] -> [(k, (k, s, i))])
-> [(k, s, i)]
-> Map k (k, s, i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, s, i) -> (k, (k, s, i))) -> [(k, s, i)] -> [(k, (k, s, i))]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: (k, s, i)
t@(k
k,s
_,i
_) -> (k
k,(k, s, i)
t))

-- entry for memoization
matchFunctions :: (Expression e) => PGSF e -> Type -> Recomp e
matchFunctions :: PGSF e -> Type -> Recomp e
matchFunctions PGSF e
memodeb Type
ty = -- mapDepth (filter (not . isAbsent (getArity ty))) $       -- KOKO 1
                            case Type -> ([Type], Type)
splitArgs (Type -> Type
saferQuantify Type
ty) of ([Type]
avail,Type
t) -> PGSF e -> [Type] -> Type -> Recomp e
forall e. Expression e => PGSF e -> [Type] -> Type -> Recomp e
matchFuns PGSF e
memodeb [Type]
avail Type
t

-- saferQuantify ty = let offset = maxVarID (unquantify ty) + 1 in quantify' $ mapTV (offset+) ty

matchFuns :: Expression e => PGSF e -> [Type] -> Type -> Recomp e
matchFuns :: PGSF e -> [Type] -> Type -> Recomp e
matchFuns PGSF e
memodeb [Type]
avail Type
reqret = (Int -> Bag e -> Bag e) -> Recomp e -> Recomp e
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag e
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag e
es) (Recomp e -> Recomp e) -> Recomp e -> Recomp e
forall a b. (a -> b) -> a -> b
$ Recomp (Bag e) -> Recomp e
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (Recomp (Bag e) -> Recomp e) -> Recomp (Bag e) -> Recomp e
forall a b. (a -> b) -> a -> b
$ PriorSubsts Recomp (Bag e) -> Recomp (Bag e)
forall (m :: * -> *) a. Monad m => PriorSubsts m a -> m a
runPS (Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp (Bag e)
forall e.
Expression e =>
Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
matchFuns' Generator Recomp e
forall e. Expression e => Generator Recomp e
unifyableExprs PGSF e
memodeb [Type]
avail Type
reqret)

matchFuns' :: Expression e => Generator Recomp e -> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ．
matchFuns' :: Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
matchFuns' Generator Recomp e
rec md :: PGSF e
md@(PGSF (CL MemoDeb e
classLib, (([[Prim]], [[Prim]])
_,([[Prim]]
primgen,[[Prim]]
primmono)),Common
cmn) TypeTrie
_ ExpTrie e
_) [Type]
avail Type
reqret
    = let clbehalf :: Type -> PriorSubsts Recomp [e]
clbehalf  = Generator Recomp e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguPrograms MemoDeb e
classLib
          behalf :: Type -> PriorSubsts Recomp ([e], BitSet)
behalf    = Generator Recomp e
rec PGSF e
md [Type]
avail
          lltbehalf :: Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf = Int -> Generator Recomp e -> Generator Recomp e
forall (m :: * -> *) e.
(Search m, Expression e) =>
Int -> Generator m e -> Generator m e
lookupListrie Int
lenavails Generator Recomp e
rec PGSF e
md [Type]
avail -- heuristic filtration
          lenavails :: Int
lenavails = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail
          fullBits :: BitSet
fullBits | Int
lenavails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 = BitSet
0
                   | Bool
otherwise      = (BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
lenavails) BitSet -> BitSet -> BitSet
forall a. Num a => a -> a -> a
- BitSet
1
--          fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration
          fe :: Type -> Type -> [e] -> [e]
fe        = Bool -> Type -> Type -> [e] -> [e]
forall e. Expression e => Bool -> Type -> Type -> [e] -> [e]
filtExprs (Opt () -> Bool
forall a. Opt a -> Bool
guess (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn)
      in Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
fromAssumptionsBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf (\Type
a Type
b -> Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ Type
aType -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
b) Type
reqret [Type]
avail PriorSubsts Recomp [e]
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
         (Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag ([e], Subst, TyVar) -> Bag ([e], Subst, TyVar))
-> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag ([e], Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lenavails then [] else Bag ([e], Subst, TyVar)
es))
                   ((Prim -> PriorSubsts Recomp [e])
-> [[Prim]] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum (Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
retPrimMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
matchPS Type
reqret) [[Prim]]
primmono PriorSubsts Recomp [e]
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                    (Prim -> PriorSubsts Recomp [e])
-> [[Prim]] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum ((    if Opt () -> Bool
forall a. Opt a -> Bool
tv0 (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn then Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e i b c.
(Expression e, Integral i) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> b)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp b
retGenTV0Bits else
                                 if Opt () -> Bool
forall a. Opt a -> Bool
tv1 (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn then Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e i c.
(Expression e, Integral i) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp [e]
retGenTV1Bits else Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall (n :: * -> *) r i c.
(Search n, Integral i, Expression r) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [r] -> [r])
-> (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n [r]
retGenOrdBits) Common
cmn Int
lenavails BitSet
fullBits Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret) [[Prim]]
primgen)
--          mapSum (retGenTV1Bits cmn lenavails fe clbehalf lltbehalf behalf reqret) primgen

fromAssumptionsBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> [Type] -> PriorSubsts Recomp [e]
fromAssumptionsBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
fromAssumptionsBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret [Type]
avail = [PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e])
-> [PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$ ((Int, Type) -> PriorSubsts Recomp [e])
-> [(Int, Type)] -> [PriorSubsts Recomp [e]]
forall a b. (a -> b) -> [a] -> [b]
map (Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
retMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((Type -> Type -> PriorSubsts Recomp ())
-> Type -> Type -> PriorSubsts Recomp ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret)) ([Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Type]
avail)

retMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ()) -> (Int, Type) -> PriorSubsts Recomp [e]
retMonoBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
retMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> PriorSubsts Recomp ()
tok (Int, Type)
fromBlah
                  = do let (Int
n, Type
ty) = (Int, Type)
fromBlah
                           (Int
arity,[Type]
args,Type
retty) = Type -> (Int, [Type], Type)
forall i. Integral i => Type -> (i, [Type], Type)
revSplitArgs Type
ty
                       Type -> PriorSubsts Recomp ()
tok Type
retty
{-
                       (es,ixBits) <- convertPS (ndelay arity) $
                                      fapBits behalf args ([ mkHead (reducer cmn) lenavails arity $ X n], 1 `shiftL` n)
                       guard $ ixBits == fullBits    -- KOKO 2
                       return es
-}
                       (Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$
                                      (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
forall a. HasCallStack => a
undefined Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty ([ (CoreExpr -> Dynamic) -> Int -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Int
0 Int
arity (CoreExpr -> e) -> CoreExpr -> e
forall a b. (a -> b) -> a -> b
$ TyVar -> CoreExpr
X (TyVar -> CoreExpr) -> TyVar -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n], BitSet
fullBits BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`clearBit` Int
n)



retPrimMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> Prim -> PriorSubsts Recomp [e]
retPrimMonoBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
retPrimMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret (Int
numcxts, Int
arity, Type
retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
                                              = do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
                                                   Type -> Type -> PriorSubsts Recomp ()
mps ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
retty) Type
reqret
                                                   (Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$
                                                             (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> Int -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Int
numcxts Int
arity) [CoreExpr]
xs, BitSet
fullBits)

funApSubBits, funApSubBits_resetting :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ([e],BitSet)) -> (Type -> PriorSubsts m ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts m ([e],BitSet)
funApSubBits :: (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits = (e -> e -> e)
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) (m :: * -> *) a r a2.
(Monad m, Monad m, Bits a) =>
(r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits e -> e -> e
forall e. Expression e => e -> e -> e
(<$>)
funApSubOpBits :: (r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits r -> a2 -> r
op Type -> m (m a2)
clbehalf Type -> m (m a2, a)
lltbehalf Type -> m (m a2, a)
behalf = Type -> (m r, a) -> m (m r, a)
faso
    where faso :: Type -> (m r, a) -> m (m r, a)
faso (Type
t:=>Type
ts) (m r
funs, a
bsf)
              = do m a2
args <- Type -> m (m a2)
clbehalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf)
          faso (Type
t:> Type
ts) (m r
funs, a
bsf)
              = do (m a2
args, a
bse) <- Type -> m (m a2, a)
lltbehalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
bse)
          -- original. 
          faso (Type
t:->Type
ts) (m r
funs, a
bsf)
              = do (m a2
args, a
bse) <- Type -> m (m a2, a)
behalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
bse)
          faso Type
_        (m r, a)
tup = (m r, a) -> m (m r, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r, a)
tup
funApSubBits_resetting :: (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits_resetting = (e -> e -> e)
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) (m :: * -> *) a r a2.
(Monad m, Monad m, Bits a) =>
(r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits_resetting e -> e -> e
forall e. Expression e => e -> e -> e
(<$>)
funApSubOpBits_resetting :: (r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits_resetting r -> a2 -> r
op Type -> m (m a2)
clbehalf Type -> m (m a2, a)
lltbehalf Type -> m (m a2, a)
behalf = Type -> (m r, a) -> m (m r, a)
faso
    where faso :: Type -> (m r, a) -> m (m r, a)
faso (Type
t:=>Type
ts) (m r
funs, a
bsf)
              = do m a2
args <- Type -> m (m a2)
clbehalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf)
          faso (Type
t:> Type
ts) (m r
funs, a
bsf)
              = do (m a2
args, a
bse) <- Type -> m (m a2, a)
lltbehalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement a
bse)
          -- original. 
          faso (Type
t:->Type
ts) (m r
funs, a
bsf)
              = do (m a2
args, a
bse) <- Type -> m (m a2, a)
behalf Type
t
                   Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement a
bse)
          faso Type
_        (m r, a)
tup = (m r, a) -> m (m r, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r, a)
tup
fapBits :: (t -> m (m r, b)) -> t t -> (m r, b) -> m (m r, b)
fapBits t -> m (m r, b)
behalf t t
ts (m r, b)
tups = ((m r, b) -> t -> m (m r, b)) -> (m r, b) -> t t -> m (m r, b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ (m r
fs,b
bsf) t
t -> do (m r
args, b
bse) <- t -> m (m r, b)
behalf t
t
                                                   (m r, b) -> m (m r, b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((r -> r -> r) -> m r -> m r -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) m r
fs m r
args, b
bsf b -> b -> b
forall a. Bits a => a -> a -> a
.|. b
bse))
                               (m r, b)
tups
                               t t
ts

forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining = (Recomp (e, Subst, TyVar) -> Recomp (e, Subst, TyVar))
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag (e, Subst, TyVar) -> Bag (e, Subst, TyVar))
-> Recomp (e, Subst, TyVar) -> Recomp (e, Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag (e, Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BitSet -> Int
countBits BitSet
newRemaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag (e, Subst, TyVar)
es))

funApSubBits_forcingNil :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts Recomp [e]
funApSubBits_forcingNil :: (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty = (e -> e -> e)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall (m :: * -> *) r a2.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> PriorSubsts Recomp (m r)
funApSubOpBits_forcingNil  (String -> e -> e -> e
forall e. Expression e => String -> e -> e -> e
aeAppErr (String
" to the request of "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
ty)) Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty
funApSubBits_forcingNil_cont :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> (([e],BitSet) -> PriorSubsts Recomp [e]) -> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont :: (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty = (e -> e -> e)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall (m :: * -> *) r a2 e.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont (String -> e -> e -> e
forall e. Expression e => String -> e -> e -> e
aeAppErr (String
" to the request of "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
ty)) Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty
funApSubOpBits_forcingNil_cont :: (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf = Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
forall e.
Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso
    where faso :: Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso (Type
t:=>Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont 
              = do m a2
args <- Type -> PriorSubsts Recomp (m a2)
clbehalf Type
t
                   Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
          faso (Type
t:> Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
              = do (m a2
args, BitSet
bse) <- Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type
t
                   let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
                   BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp e -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall a b. (a -> b) -> a -> b
$
                     Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
newRemaining) (m r, BitSet) -> PriorSubsts Recomp e
cont
          -- original. 
          faso (Type
t:->Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
              = do (m a2
args, BitSet
bse) <- Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t
                   let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
                   BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp e -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall a b. (a -> b) -> a -> b
$ 
                     Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
newRemaining) (m r, BitSet) -> PriorSubsts Recomp e
cont
          faso Type
_        (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont = (m r, BitSet) -> PriorSubsts Recomp e
cont (m r
funs, BitSet
bsf)
funApSubOpBits_forcingNil :: (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> PriorSubsts Recomp (m r)
funApSubOpBits_forcingNil r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t (m r, BitSet)
tup
  = (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp (m r))
-> PriorSubsts Recomp (m r)
forall (m :: * -> *) r a2 e.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t (m r, BitSet)
tup (((m r, BitSet) -> PriorSubsts Recomp (m r))
 -> PriorSubsts Recomp (m r))
-> ((m r, BitSet) -> PriorSubsts Recomp (m r))
-> PriorSubsts Recomp (m r)
forall a b. (a -> b) -> a -> b
$ \(m r
funs, BitSet
bsf) ->
                                      do Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
bsf BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
                                         m r -> PriorSubsts Recomp (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return m r
funs
-- Data.Bits.popCount does the job. However, instance Bits Integer uses popCountDefault, which uses the naive algorithm.
countBits32 :: a -> b
countBits32 a
bin 
  = let quad :: a
quad = a
bin a -> a -> a
forall a. Num a => a -> a -> a
- ((a
bin a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x55555555) -- quadary coded
        hex :: a
hex  = (a
quad a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x33333333) a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
quad a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x33333333) -- hexadecimalary coded
    in a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ ((((a
hex a -> a -> a
forall a. Num a => a -> a -> a
+ (a
hex a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0F0F0F0F) a -> a -> a
forall a. Num a => a -> a -> a
* a
0x01010101) a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF -- The last (.&. 0xFF) should not be necessary when using Word32.

retGenOrdBits :: Common
-> i
-> BitSet
-> (Type -> Type -> [r] -> [r])
-> (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n [r]
retGenOrdBits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [r] -> [r]
fe Type -> PriorSubsts n [r]
clbehalf Type -> PriorSubsts n ([r], BitSet)
lltbehalf Type -> PriorSubsts n ([r], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
  = (n ([r], Subst, TyVar) -> n ([r], Subst, TyVar))
-> PriorSubsts n [r] -> PriorSubsts n [r]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> n ([r], Subst, TyVar) -> n ([r], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts n [r] -> PriorSubsts n [r])
-> PriorSubsts n [r] -> PriorSubsts n [r]
forall a b. (a -> b) -> a -> b
$              do TyVar
tvid <- TyVar -> PriorSubsts n TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？
                                               --                                                              -- unitSubstをinlineにしないと駄目か
                                               Int
a <- Int -> TyVar -> Type -> PriorSubsts n Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
                                               ([r]
exprs, BitSet
bs1) <- (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> ([r], BitSet)
-> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits_resetting Type -> PriorSubsts n [r]
clbehalf Type -> PriorSubsts n ([r], BitSet)
lltbehalf Type -> PriorSubsts n ([r], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> r) -> [CoreExpr] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> r
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
a)) [CoreExpr]
xs, BitSet
fullBits)
                                               Type
gentvar <- Type -> PriorSubsts n Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
                                               Bool -> PriorSubsts n ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
orderedAndUsedArgs Type
gentvar) -- この辺のcheckをTVnに入る前の早い段階にやるのは1つの考え方だが，TVn中にreplaceされたりはしないのか?
                                               ([r]
es, BitSet
bs2) <- Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' Bool
False Type
gentvar (Type -> Type -> [r] -> [r]
fe Type
gentvar Type
ty [r]
exprs, BitSet
bs1)
                                               Bool -> PriorSubsts n ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts n ()) -> Bool -> PriorSubsts n ()
forall a b. (a -> b) -> a -> b
$ BitSet
bs2 BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
                                               [r] -> PriorSubsts n [r]
forall (m :: * -> *) a. Monad m => a -> m a
return [r]
es
    where
--                    funApSub'' filtexp (TV _ :-> _)     funs = mzero -- mkSubstsで導入されたtyvarsが使われていないケース．replaceされた結果TVってケースはとりあえず無視....
                    funApSub'' :: Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' Bool
filtexp (Type
t:->ts :: Type
ts@(Type
u:->Type
_)) ([r]
funs, BitSet
bs)
--                        | t > u     = mzero
                        | Bool
otherwise = do ([r]
args, BitSet
ixs) <- Type -> PriorSubsts n ([r], BitSet)
behalf Type
t
                                         Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' (Type
tType -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
u) Type
ts (if Bool
filtexp then [ r
f r -> r -> r
forall e. Expression e => e -> e -> e
<$> r
e | r
f <- [r]
funs, r
e <- [r]
args, let CoreExpr
_:$CoreExpr
d = r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
e ]
                                                                         else (r -> r -> r) -> [r] -> [r] -> [r]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) [r]
funs [r]
args,  
                                                               BitSet
bs BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ixs)
-- てゆーかtとuが同じならばもっといろんなことができそう．
                    funApSub'' Bool
filtexp (Type
t:->Type
ts) ([r]
funs, BitSet
bs)
                                    = do ([r]
args, BitSet
ixs) <- Type -> PriorSubsts n ([r], BitSet)
behalf Type
t
                                         ([r], BitSet) -> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
filtexp then [ r
f r -> r -> r
forall e. Expression e => e -> e -> e
<$> r
e | r
f <- [r]
funs, r
e <- [r]
args, let CoreExpr
_:$CoreExpr
d = r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
e]
                                                            else (r -> r -> r) -> [r] -> [r] -> [r]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) [r]
funs [r]
args,  
                                                 BitSet
bs BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ixs)
                    funApSub'' Bool
_fe Type
_t ([r], BitSet)
tups = ([r], BitSet) -> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([r], BitSet)
tups

retGenTV1Bits :: Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp [e]
retGenTV1Bits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
  = (Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$              do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？
                                               --                                                              -- unitSubstをinlineにしないと駄目か
                                               Int
a <- Int -> TyVar -> Type -> PriorSubsts Recomp Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubst (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
{-                                               
                                               (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits)
                                               gentvar <- applyPS (TV tvid)
                                               guard (usedArg (tvid+1) gentvar)
                                               funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1)
-}
                                               (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
a)) [CoreExpr]
xs, BitSet
fullBits) ((([e], BitSet) -> PriorSubsts Recomp [e])
 -> PriorSubsts Recomp [e])
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$ \([e]
exprs, BitSet
bs1) -> do
                                                 Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
                                                 Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyVar -> Type -> Bool
usedArg (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) Type
gentvar)
                                                 (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
gentvar (Type -> Type -> [e] -> [e]
fe Type
gentvar Type
ty [e]
exprs, BitSet
bs1)

retGenTV0Bits :: Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> b)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp b
retGenTV0Bits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [e] -> b
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
  = (Recomp (b, Subst, TyVar) -> Recomp (b, Subst, TyVar))
-> PriorSubsts Recomp b -> PriorSubsts Recomp b
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp (b, Subst, TyVar) -> Recomp (b, Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp b -> PriorSubsts Recomp b)
-> PriorSubsts Recomp b -> PriorSubsts Recomp b
forall a b. (a -> b) -> a -> b
$              do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？
                                               --                                                              -- unitSubstをinlineにしないと駄目か
                                               Subst -> PriorSubsts Recomp ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (TyVar -> Type -> Subst
forall a b. a -> b -> [(a, b)]
unitSubst TyVar
tvid Type
reqret)
                                               [e]
exprs <- (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts Int
arity) [CoreExpr]
xs, BitSet
fullBits)
                                               Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
                                               b -> PriorSubsts Recomp b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> PriorSubsts Recomp b) -> b -> PriorSubsts Recomp b
forall a b. (a -> b) -> a -> b
$ Type -> Type -> [e] -> b
fe Type
gentvar Type
ty [e]
exprs




matchAssumptionsBits :: (Functor m, MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m ([e],BitSet)
matchAssumptionsBits :: Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
matchAssumptionsBits Common
cmn Int
lenavails Type
reqty [Type]
assumptions
    = do Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
         let newty :: Type
newty = Subst -> Type -> Type
apply Subst
s Type
reqty
             (Integer
numcxts, Integer
arity) = Type -> (Integer, Integer)
forall i. Integral i => Type -> (i, i)
getArities Type
newty
         [PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet))
-> [PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet)
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type -> PriorSubsts m ([e], BitSet))
-> [TyVar] -> [Type] -> [PriorSubsts m ([e], BitSet)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\TyVar
n Type
t -> Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
matchPS Type
newty Type
t PriorSubsts m ()
-> PriorSubsts m ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CoreExpr -> Dynamic) -> Int -> Integer -> Integer -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Integer
numcxts Integer
arity (TyVar -> CoreExpr
X TyVar
n)], BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`shiftL` TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
n)) [TyVar
0..] [Type]
assumptions
-- match の場合，通常はreqtyの方だけapply substすればよい．

lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e
lookupListrie :: Int -> Generator m e -> Generator m e
lookupListrie Int
lenavails Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
                                    | Opt () -> Bool
forall a. Opt a -> Bool
constrL Opt ()
opts = Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) e.
(Functor m, MonadPlus m, Expression e) =>
Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
matchAssumptionsBits Common
cmn Int
lenavails Type
t [Type]
avail
                                    | Opt () -> Bool
forall a. Opt a -> Bool
guess Opt ()
opts = do
                                       ([e]
args, BitSet
ixBits) <- Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
                                       let args' :: [e]
args' = (e -> Bool) -> [e] -> [e]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CoreExpr -> Bool
isClosed(CoreExpr -> Bool) -> (e -> CoreExpr) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE) [e]
args
                                       Bool -> PriorSubsts m () -> PriorSubsts m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([e] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
args') PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                       ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([e]
args', BitSet
ixBits)
                                    | Bool
otherwise  = do
                                       ([e]
args, BitSet
ixBits) <- Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
                                       let args' :: [e]
args' = (e -> Bool) -> [e] -> [e]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CoreExpr -> Bool
isConstrExpr(CoreExpr -> Bool) -> (e -> CoreExpr) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE) [e]
args
                                       Bool -> PriorSubsts m () -> PriorSubsts m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([e] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
args') PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                       ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([e]
args', BitSet
ixBits)
    where opts :: Opt ()
opts = Common -> Opt ()
opt Common
cmn
          cmn :: Common
cmn  = PGSF e -> Common
forall a. WithCommon a => a -> Common
extractCommon PGSF e
memodeb
\end{code}