-- 
-- (c) Susumu Katayama
--

\begin{code}
{-# LANGUAGE CPP, RelaxedPolyRec, FlexibleInstances #-}
module MagicHaskeller.ProgGenSFIORef(ProgGenSFIORef, PGSFIOR) where
import MagicHaskeller.Types
import MagicHaskeller.TyConLib
import Control.Monad
import MagicHaskeller.CoreLang
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.ProgGen(mkCL, ClassLib(..), mguPrograms)
import MagicHaskeller.ProgGenSF(funApSub_, funApSub_spec, lookupNormalized, tokoro10fst)
import MagicHaskeller.Options(Opt(..))

import MagicHaskeller.Expression

import MagicHaskeller.MemoToFiles hiding (freezePS, fps, memoRTIO)

import MagicHaskeller.T10(mergesortWithBy, diffSortedBy)

import qualified Data.Map as M

import MagicHaskeller.DebMT

import MagicHaskeller.FMType
import Data.IORef
import Data.Array
import Data.Ix

import MagicHaskeller.ShortString(readBriefly, showBriefly)
import System.Directory(doesFileExist, createDirectoryIfMissing)

import Debug.Trace
-- trace str = id

reorganize_ :: ([Type] -> a) -> [Type] -> a
reorganize_ = ([Type] -> a) -> [Type] -> a
forall a. ([Type] -> a) -> [Type] -> a
reorganizer_
-- reorganize_ = 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 ProgGenSFIORef = PGSFIOR CoreExpr
data PGSFIOR e = PGSFIOR (ExpTrie e) (MemoDeb 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 ExpTrie  e = IORef (FMType (Array Int [e]))
-- type ExpTrie  e = MapType (ExpMatrix e) -- PGSF, PGSFIOだとこっちだった．

type TypeTrie = MapType (Matrix (Type, Subst, TyVar))

filtBFm :: Common -> Type -> DBoundT m a -> RecompT m a
filtBFm Common
cmn Type
ty | Bool
classify  = DBoundT m a -> RecompT m a
forall (m :: * -> *) a.
(Functor m, Monad m, Ord a) =>
DBoundT m a -> RecompT m a
inconsistentDBTToRcT (DBoundT m a -> RecompT m a)
-> (DBoundT m a -> DBoundT m a) -> DBoundT m a -> RecompT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnExpr -> a) -> DBoundT m AnnExpr -> DBoundT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> a
forall e. Expression e => AnnExpr -> e
fromAnnExpr (DBoundT m AnnExpr -> DBoundT m a)
-> (DBoundT m a -> DBoundT m AnnExpr) -> DBoundT m a -> DBoundT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Common -> Type -> DBoundT m AnnExpr -> DBoundT m AnnExpr
forall (m :: * -> *).
DB m =>
Common -> Type -> m AnnExpr -> m AnnExpr
filterDM Common
cmn Type
ty (DBoundT m AnnExpr -> DBoundT m AnnExpr)
-> (DBoundT m a -> DBoundT m AnnExpr)
-> DBoundT m a
-> DBoundT m AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> AnnExpr) -> DBoundT m a -> DBoundT m AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> a -> 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)  (DBoundT m a -> DBoundT m AnnExpr)
-> (DBoundT m a -> DBoundT m a) -> DBoundT m a -> DBoundT m AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Bag (a, Int) -> Bag (a, Int)) -> DBoundT m a -> DBoundT m a
forall (m :: * -> *) a b.
DB m =>
(Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
mapDepthDB Bag (a, Int) -> Bag (a, Int)
forall e. Expression e => [(e, Int)] -> [(e, Int)]
uniqSorter
               | Bool
otherwise = DBoundT m a -> RecompT m a
forall (m :: * -> *) a. Monad m => DBoundT m a -> RecompT m a
dbtToRcT (DBoundT m a -> RecompT m a)
-> (DBoundT m a -> DBoundT m a) -> DBoundT m a -> RecompT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag (a, Int) -> Bag (a, Int)) -> DBoundT m a -> DBoundT m a
forall (m :: * -> *) a b.
DB m =>
(Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
mapDepthDB Bag (a, Int) -> Bag (a, Int)
forall e. Expression e => [(e, Int)] -> [(e, Int)]
uniqSorter

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 ProgramGeneratorIO (PGSFIOR CoreExpr) where
    mkTrieOptIO :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO (PGSFIOR CoreExpr)
mkTrieOptIO Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
tcesopt [[Typed [CoreExpr]]]
tces = do IORef (FMType (Array Int [CoreExpr]))
expTrie <- FMType (Array Int [CoreExpr])
-> IO (IORef (FMType (Array Int [CoreExpr])))
forall a. a -> IO (IORef a)
newIORef FMType (Array Int [CoreExpr])
forall a. FMType a
EmptyFMT
                                              PGSFIOR CoreExpr -> IO (PGSFIOR CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (PGSFIOR CoreExpr -> IO (PGSFIOR CoreExpr))
-> PGSFIOR CoreExpr -> IO (PGSFIOR CoreExpr)
forall a b. (a -> b) -> a -> b
$ IORef (FMType (Array Int [CoreExpr]))
-> MemoDeb CoreExpr -> PGSFIOR CoreExpr
forall e. ExpTrie e -> MemoDeb e -> PGSFIOR e
PGSFIOR IORef (FMType (Array Int [CoreExpr]))
expTrie (Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> MemoDeb CoreExpr
mkTrieOptSF Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
tcesopt [[Typed [CoreExpr]]]
tces)
    unifyingProgramsIO :: Type -> PGSFIOR CoreExpr -> RecompT IO AnnExpr
unifyingProgramsIO Type
ty PGSFIOR CoreExpr
px = RecompT IO (Bag AnnExpr) -> RecompT IO AnnExpr
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (RecompT IO (Bag AnnExpr) -> RecompT IO AnnExpr)
-> RecompT IO (Bag AnnExpr) -> RecompT IO AnnExpr
forall a b. (a -> b) -> a -> b
$ (([CoreExpr], Subst, TyVar) -> Bag AnnExpr)
-> RecompT IO ([CoreExpr], Subst, TyVar)
-> RecompT IO (Bag AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ([CoreExpr]
es,Subst
_,TyVar
_) -> (CoreExpr -> AnnExpr) -> [CoreExpr] -> Bag AnnExpr
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> CoreExpr -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr ((CoreExpr -> Dynamic) -> CoreExpr -> AnnExpr)
-> (CoreExpr -> Dynamic) -> CoreExpr -> AnnExpr
forall a b. (a -> b) -> a -> b
$ Common -> CoreExpr -> Dynamic
reducer (Common -> CoreExpr -> Dynamic) -> Common -> CoreExpr -> Dynamic
forall a b. (a -> b) -> a -> b
$ PGSFIOR CoreExpr -> Common
forall a. WithCommon a => a -> Common
extractCommon PGSFIOR CoreExpr
px) [CoreExpr]
es) (RecompT IO ([CoreExpr], Subst, TyVar) -> RecompT IO (Bag AnnExpr))
-> RecompT IO ([CoreExpr], Subst, TyVar)
-> RecompT IO (Bag AnnExpr)
forall a b. (a -> b) -> a -> b
$ DBoundT IO ([CoreExpr], Subst, TyVar)
-> RecompT IO ([CoreExpr], Subst, TyVar)
forall (m :: * -> *) a. Monad m => DBoundT m a -> RecompT m a
dbtToRcT (DBoundT IO ([CoreExpr], Subst, TyVar)
 -> RecompT IO ([CoreExpr], Subst, TyVar))
-> DBoundT IO ([CoreExpr], Subst, TyVar)
-> RecompT IO ([CoreExpr], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Type -> PGSFIOR CoreExpr -> DBoundT IO ([CoreExpr], Subst, TyVar)
unifyingPossibilitiesIO Type
ty PGSFIOR CoreExpr
px
instance Expression e => WithCommon (PGSFIOR e) where
    extractCommon :: PGSFIOR e -> Common
extractCommon    (PGSFIOR ExpTrie e
_ (ClassLib e
_,TypeTrie
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn))      = Common
cmn

unifyingPossibilitiesIO :: Type -> PGSFIOR CoreExpr -> DBoundT IO ([CoreExpr], Subst, TyVar)
unifyingPossibilitiesIO Type
ty PGSFIOR CoreExpr
pg = PriorSubsts (DBoundT IO) [CoreExpr]
-> Subst -> TyVar -> DBoundT IO ([CoreExpr], Subst, TyVar)
forall (m :: * -> *) a.
PriorSubsts m a -> Subst -> TyVar -> m (a, Subst, TyVar)
unPS (Generator (DBoundT IO) CoreExpr
unifyableExprsIO PGSFIOR CoreExpr
pg [] Type
ty) Subst
forall a. [a]
emptySubst TyVar
0


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

mkTrieOptSF :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> MemoDeb CoreExpr
mkTrieOptSF :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> MemoDeb CoreExpr
mkTrieOptSF Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
txsopt [[Typed [CoreExpr]]]
txs
    = let memoDeb :: MemoDeb CoreExpr
memoDeb = (Common -> [Typed [CoreExpr]] -> ClassLib CoreExpr
mkCL Common
cmn [Typed [CoreExpr]]
classes, TypeTrie
typeTrie, (([[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 CoreExpr -> Type -> PriorSubsts Recomp Type
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> Type -> PriorSubsts m Type
specTypes MemoDeb CoreExpr
memoDeb Type
ty))
      in MemoDeb CoreExpr
memoDeb
    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
-- 非効率だけど，DBoundTに矛盾があってもいいやつ．
inconsistentDBTToRcT :: (Functor m, Monad m, Ord a) => DBoundT m a -> RecompT m a
inconsistentDBTToRcT :: DBoundT m a -> RecompT m a
inconsistentDBTToRcT (DBT Int -> m (Bag (a, Int))
f) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ((Int -> m (Bag a)) -> RecompT m a)
-> (Int -> m (Bag a)) -> RecompT m a
forall a b. (a -> b) -> a -> b
$ \Int
d -> do [Bag (a, Int)]
tss <- (Int -> m (Bag (a, Int))) -> [Int] -> m [Bag (a, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> m (Bag (a, Int))
f [Int
0..Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                                              Bag (a, Int)
ts  <- Int -> m (Bag (a, Int))
f Int
d
                                              Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag a -> m (Bag a)) -> Bag a -> m (Bag a)
forall a b. (a -> b) -> a -> b
$ (Bag a -> Bag a -> Bag a) -> Bag a -> [Bag a] -> Bag a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((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) (((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)
ts) ((Bag (a, Int) -> Bag a) -> [Bag (a, Int)] -> [Bag a]
forall a b. (a -> b) -> [a] -> [b]
map (((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)]
tss)
-- what to memoize about exptrie
computeExpTip :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
computeExpTip :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
computeExpTip md :: PGSFIOR CoreExpr
md@(PGSFIOR IORef (FMType (Array Int [CoreExpr]))
_ (ClassLib CoreExpr
_,TypeTrie
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn)) Type
ty = Common -> Type -> DBoundT IO CoreExpr -> RecompT IO CoreExpr
forall (m :: * -> *) a.
(Monad m, Expression a) =>
Common -> Type -> DBoundT m a -> RecompT m a
filtBFm Common
cmn Type
ty (DBoundT IO CoreExpr -> RecompT IO CoreExpr)
-> DBoundT IO CoreExpr -> RecompT IO CoreExpr
forall a b. (a -> b) -> a -> b
$ PGSFIOR CoreExpr -> Type -> DBoundT IO CoreExpr
matchFunctionsIO PGSFIOR CoreExpr
md Type
ty

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 :: 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
      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) 

tokoro10ap :: [(Type,s,i)] -> [(Type,s,i)]
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
_) -> (Type
ty, (Type, s, i)
t))




specializedTypes :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ([Type],Type)
specializedTypes :: MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ([Type], Type)
specializedTypes MemoDeb CoreExpr
memodeb [Type]
avail Type
t = do MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specializedCases MemoDeb CoreExpr
memodeb [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, specCases' :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specializedCases :: MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specializedCases MemoDeb CoreExpr
memodeb = ([Type] -> Type -> PriorSubsts m ())
-> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo (MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specCases MemoDeb CoreExpr
memodeb)
specCases :: MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specCases MemoDeb CoreExpr
memodeb = ([Type] -> Type -> PriorSubsts m ())
-> [Type] -> Type -> PriorSubsts m ()
forall a. ([Type] -> Type -> a) -> [Type] -> Type -> a
wind_ (\[Type]
avail Type
reqret -> ([Type] -> PriorSubsts m ()) -> [Type] -> PriorSubsts m ()
forall a. ([Type] -> a) -> [Type] -> a
reorganize_ (\[Type]
newavail -> MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
uniExprs_ MemoDeb CoreExpr
memodeb [Type]
newavail Type
reqret) [Type]
avail)
{- どっちがわかりやすいかは不明
specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1
specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail
-}





uniExprs_ :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
uniExprs_ :: MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
uniExprs_ MemoDeb CoreExpr
memodeb [Type]
avail Type
t
    = (Recomp ((), Subst, TyVar) -> m ((), Subst, TyVar))
-> PriorSubsts Recomp () -> PriorSubsts m ()
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS Recomp ((), Subst, TyVar) -> m ((), Subst, TyVar)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (PriorSubsts Recomp () -> PriorSubsts m ())
-> PriorSubsts Recomp () -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$ (Int -> PriorSubsts [] ()) -> PriorSubsts Recomp ()
forall a. (Int -> PriorSubsts [] a) -> PriorSubsts Recomp a
psListToPSRecomp Int -> PriorSubsts [] ()
lfp
    where lfp :: Int -> PriorSubsts [] ()
lfp Int
depth
              | Int -> Bool
forall p. p -> Bool
memocond Int
depth     = MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type
forall e.
Expression e =>
MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type
lookupUniExprs MemoDeb CoreExpr
memodeb [Type]
avail Type
t Int
depth PriorSubsts [] Type -> PriorSubsts [] () -> PriorSubsts [] ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> PriorSubsts [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise          = MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type
makeUniExprs MemoDeb CoreExpr
memodeb [Type]
avail Type
t Int
depth PriorSubsts [] Type -> PriorSubsts [] () -> PriorSubsts [] ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> PriorSubsts [] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type
lookupUniExprs :: MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type
lookupUniExprs memodeb :: MemoDeb e
memodeb@(ClassLib e
_,TypeTrie
mt,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
_) [Type]
avail Type
t Int
depth
    = (Type -> Bag (Type, Subst, TyVar))
-> [Type] -> Type -> PriorSubsts [] Type
forall (m :: * -> *) e.
(Functor m, MonadPlus m) =>
(Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e
lookupNormalized  (\Type
tn -> Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
mt Type
tn) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
depth) [Type]
avail Type
t

makeUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type
makeUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type
makeUniExprs MemoDeb CoreExpr
memodeb [Type]
avail Type
t Int
depth
    = (Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar))
-> PriorSubsts [] Type -> PriorSubsts [] Type
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar)
forall k s i. (Eq k, Ord k) => [(k, s, i)] -> [(k, s, i)]
tokoro10fst (PriorSubsts [] Type -> PriorSubsts [] Type)
-> PriorSubsts [] Type -> PriorSubsts [] Type
forall a b. (a -> b) -> a -> b
$
                do PriorSubsts Recomp () -> Int -> PriorSubsts [] ()
forall a. PriorSubsts Recomp a -> Int -> PriorSubsts [] a
psRecompToPSList (([Type] -> PriorSubsts Recomp ())
-> [Type] -> PriorSubsts Recomp ()
forall a. ([Type] -> a) -> [Type] -> a
reorganize_ (\[Type]
av -> MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specCases' MemoDeb CoreExpr
memodeb [Type]
av Type
t) [Type]
avail) Int
depth
                   Subst
sub   <- PriorSubsts [] Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                   Type -> PriorSubsts [] Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PriorSubsts [] Type) -> Type -> PriorSubsts [] Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
quantify (Subst -> Type -> Type
apply Subst
sub (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
popArgs [Type]
avail Type
t)


-- entry point for memoization
specTypes :: (Search m) => MemoDeb CoreExpr -> Type -> PriorSubsts m Type
specTypes :: MemoDeb CoreExpr -> Type -> PriorSubsts m Type
specTypes MemoDeb CoreExpr
memodeb Type
ty
                           = do let ([Type]
avail,Type
t) = Type -> ([Type], Type)
splitArgs Type
ty
                                ([Type] -> PriorSubsts m ()) -> [Type] -> PriorSubsts m ()
forall a. ([Type] -> a) -> [Type] -> a
reorganize_ (\[Type]
av -> MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specCases' MemoDeb CoreExpr
memodeb [Type]
av Type
t) [Type]
avail
-- quantifyはmemo先で既にやられているので不要
                                Type
typ <- Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
ty
                                Type -> PriorSubsts m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
normalize Type
typ)


-- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen)
specCases' :: MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specCases' memodeb :: MemoDeb CoreExpr
memodeb@(CL MemoDeb (ClassLib CoreExpr) CoreExpr
classLib, TypeTrie
ttrie, (prims :: ([[Prim]], [[Prim]])
prims@([[Prim]]
primgen,[[Prim]]
primmono),([[Prim]], [[Prim]])
_),Common
cmn) [Type]
avail Type
reqret
 = (Prim -> PriorSubsts m ()) -> [[Prim]] -> PriorSubsts m ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts m ()
forall i a a.
Integral i =>
(a, i, Type, TyVar, Typed a) -> PriorSubsts m ()
retPrimMono [[Prim]]
primmono PriorSubsts m () -> PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [PriorSubsts m ()] -> PriorSubsts m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((Type -> PriorSubsts m ()) -> [Type] -> [PriorSubsts m ()]
forall a b. (a -> b) -> [a] -> [b]
map Type -> PriorSubsts m ()
retMono [Type]
avail) PriorSubsts m () -> PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Prim -> PriorSubsts m ()) -> [[Prim]] -> PriorSubsts m ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts m ()
forall i a c a.
Integral i =>
(a, i, c, TyVar, Typed a) -> PriorSubsts m ()
retGen [[Prim]]
primgen
    where fas :: Type -> PriorSubsts m ()
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 m ())
-> (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m ())
-> Type
-> PriorSubsts m ()
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 ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m ()
lltbehalf Type -> PriorSubsts m ()
behalf
              | Bool
otherwise         = (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m ()
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_spec      Type -> PriorSubsts m ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m ()
behalf
              where behalf :: Type -> PriorSubsts m ()
behalf    = MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
Search m =>
MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ()
specializedCases MemoDeb CoreExpr
memodeb [Type]
avail
                    lltbehalf :: Type -> PriorSubsts m ()
lltbehalf = (Type -> [Type] -> PriorSubsts m ())
-> [Type] -> Type -> PriorSubsts m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> [Type] -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> [Type] -> PriorSubsts m ()
mguAssumptions_ [Type]
avail
                    clbehalf :: Type -> PriorSubsts m ()
clbehalf  Type
ty = Generator m CoreExpr
forall (m :: * -> *). Search m => Generator m CoreExpr
mguPrograms MemoDeb (ClassLib CoreExpr) CoreExpr
classLib [] Type
ty PriorSubsts m [CoreExpr] -> 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 ()
          -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()
          retPrimMono :: (a, i, Type, TyVar, Typed a) -> PriorSubsts m ()
retPrimMono (a
_, i
arity, Type
retty, TyVar
numtvs, a
_xs:::Type
ty)
                                              = i
-> (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m ()
-> PriorSubsts m ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m () -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$
                                                do TyVar
tvid <- TyVar -> PriorSubsts m TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
                                                   Type -> Type -> PriorSubsts m ()
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 -> PriorSubsts m ()
fas ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty)
          -- retMono :: Type -> PriorSubsts BFT ()
          retMono :: Type -> PriorSubsts m ()
retMono Type
ty = Integer
-> (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m ()
-> PriorSubsts m ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Type -> Integer
forall i. Integral i => Type -> i
getArity Type
ty) PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m () -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$
                       do Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret (Type -> Type
getRet Type
ty)
                          Type -> PriorSubsts m ()
fas Type
ty
          -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()
          retGen :: (a, i, c, TyVar, Typed a) -> PriorSubsts m ()
retGen (a
_, i
arity, c
_r, TyVar
numtvs, a
_s:::Type
ty) = i
-> (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m ()
-> PriorSubsts m ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts m () -> PriorSubsts m ())
-> PriorSubsts m () -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$
                                             do TyVar
tvid <- TyVar -> PriorSubsts m 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 m 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 m ()
fas ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty)

                                                Type
gentvar <- Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)

                                                Bool -> PriorSubsts m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
orderedAndUsedArgs Type
gentvar)
                                                Type -> PriorSubsts m ()
fas Type
gentvar

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

unifyableExprsIO :: Generator (DBoundT IO) CoreExpr
unifyableExprsIO :: Generator (DBoundT IO) CoreExpr
unifyableExprsIO PGSFIOR CoreExpr
memodeb = ([Type] -> Type -> PriorSubsts (DBoundT IO) [CoreExpr])
-> [Type] -> Type -> PriorSubsts (DBoundT IO) [CoreExpr]
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo ((PriorSubsts (DBoundT IO) [CoreExpr]
 -> PriorSubsts (DBoundT IO) [CoreExpr])
-> ([Type] -> Type -> PriorSubsts (DBoundT IO) [CoreExpr])
-> [Type]
-> Type
-> PriorSubsts (DBoundT IO) [CoreExpr]
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind (([CoreExpr] -> [CoreExpr])
-> PriorSubsts (DBoundT IO) [CoreExpr]
-> PriorSubsts (DBoundT IO) [CoreExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall e. Expression e => (CoreExpr -> CoreExpr) -> e -> e
mapCE CoreExpr -> CoreExpr
Lambda))) ((Type -> DBoundT IO ([CoreExpr], Subst, TyVar))
-> [Type] -> Type -> PriorSubsts (DBoundT IO) [CoreExpr]
forall (m :: * -> *) e.
(Functor m, MonadPlus m) =>
(Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e
lookupNormalized (PGSFIOR CoreExpr -> Type -> DBoundT IO ([CoreExpr], Subst, TyVar)
lookupTypeTrieIO PGSFIOR CoreExpr
memodeb)))

memocondexp :: p -> a -> Bool
memocondexp p
_ a
d = a
0a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
d -- なんか条件がProgGenSFIOでは逆になってるかも．
memodepth :: p -> p
memodepth p
_ = p
1


lookupTypeTrieIO :: PGSFIOR CoreExpr -> Type -> DBoundT IO ([CoreExpr], Subst, TyVar)
lookupTypeTrieIO :: PGSFIOR CoreExpr -> Type -> DBoundT IO ([CoreExpr], Subst, TyVar)
lookupTypeTrieIO md :: PGSFIOR CoreExpr
md@(PGSFIOR IORef (FMType (Array Int [CoreExpr]))
_ (ClassLib CoreExpr
_, TypeTrie
mt, (([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_, Common
_)) Type
t
    = (Int -> IO (Bag (([CoreExpr], Subst, TyVar), Int)))
-> DBoundT IO ([CoreExpr], Subst, TyVar)
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> IO (Bag (([CoreExpr], Subst, TyVar), Int)))
 -> DBoundT IO ([CoreExpr], Subst, TyVar))
-> (Int -> IO (Bag (([CoreExpr], Subst, TyVar), Int)))
-> DBoundT IO ([CoreExpr], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
db -> ([Bag (([CoreExpr], Subst, TyVar), Int)]
 -> Bag (([CoreExpr], Subst, TyVar), Int))
-> IO [Bag (([CoreExpr], Subst, TyVar), Int)]
-> IO (Bag (([CoreExpr], Subst, TyVar), Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bag (([CoreExpr], Subst, TyVar), Int)]
-> Bag (([CoreExpr], Subst, TyVar), Int)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [Bag (([CoreExpr], Subst, TyVar), Int)]
 -> IO (Bag (([CoreExpr], Subst, TyVar), Int)))
-> IO [Bag (([CoreExpr], Subst, TyVar), Int)]
-> IO (Bag (([CoreExpr], Subst, TyVar), Int))
forall a b. (a -> b) -> a -> b
$ ((Type, Subst, TyVar)
 -> IO (Bag (([CoreExpr], Subst, TyVar), Int)))
-> Bag (Type, Subst, TyVar)
-> IO [Bag (([CoreExpr], Subst, TyVar), Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PGSFIOR CoreExpr
-> Int
-> (Type, Subst, TyVar)
-> IO (Bag (([CoreExpr], Subst, TyVar), Int))
procTup PGSFIOR CoreExpr
md Int
db) (Bag (Type, Subst, TyVar)
 -> IO [Bag (([CoreExpr], Subst, TyVar), Int)])
-> Bag (Type, Subst, TyVar)
-> IO [Bag (([CoreExpr], Subst, TyVar), Int)]
forall a b. (a -> b) -> a -> b
$ Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
mt Type
t) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
db
procTup :: PGSFIOR CoreExpr -> Int -> (Type, Subst, TyVar) -> IO [(([CoreExpr],Subst,TyVar),Int)]
procTup :: PGSFIOR CoreExpr
-> Int
-> (Type, Subst, TyVar)
-> IO (Bag (([CoreExpr], Subst, TyVar), Int))
procTup PGSFIOR CoreExpr
md Int
db (Type
ty, Subst
s, TyVar
i) = (Int -> IO (([CoreExpr], Subst, TyVar), Int))
-> [Int] -> IO (Bag (([CoreExpr], Subst, TyVar), Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
depth -> RecompT IO CoreExpr -> Int -> IO [CoreExpr]
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
lookupReorganizedIO PGSFIOR CoreExpr
md Type
ty) Int
depth IO [CoreExpr]
-> ([CoreExpr] -> IO (([CoreExpr], Subst, TyVar), Int))
-> IO (([CoreExpr], Subst, TyVar), Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[CoreExpr]
ys -> (([CoreExpr], Subst, TyVar), Int)
-> IO (([CoreExpr], Subst, TyVar), Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (([CoreExpr]
ys, Subst
s, TyVar
i), Int
dbInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
depth)) [Int
0..Int
db]
{-
lookupTypeTrieRcIO :: Expression e => MemoDeb e -> Type -> RecompT IO ([e], Subst, Int)
lookupTypeTrieRcIO md@((mt,_), _, _) t
    = RcT $ \d -> mapM (procTupRc md d) $ unMx (lmtty mt t) !! d
procTupRc md d (ty, s, i) = do mx <- lmtIO md ty
                               return (unMx mx !! d, s, i)
-}

lookupReorganizedIO :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
lookupReorganizedIO PGSFIOR CoreExpr
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] -> RecompT IO CoreExpr) -> [Type] -> RecompT IO CoreExpr
forall (m :: * -> *) e.
(Functor m, Expression e) =>
([Type] -> m e) -> [Type] -> m e
reorganizerId' (\[Type]
av -> PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
lmtIO PGSFIOR CoreExpr
md (Type -> RecompT IO CoreExpr) -> Type -> RecompT IO CoreExpr
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
popArgs [Type]
av Type
retty) [Type]
avs

-- ホントはProgGenSFのmtを使ったほうが速いはず．
lmtIO :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
lmtIO :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
lmtIO md :: PGSFIOR CoreExpr
md@(PGSFIOR IORef (FMType (Array Int [CoreExpr]))
fmtref (ClassLib CoreExpr
_,TypeTrie
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn)) Type
ty = IORef (FMType (Array Int [CoreExpr]))
-> (Type -> RecompT IO CoreExpr) -> Type -> RecompT IO CoreExpr
forall e.
Expression e =>
ExpTrie e -> (Type -> RecompT IO e) -> Type -> RecompT IO e
memoRTIO IORef (FMType (Array Int [CoreExpr]))
fmtref (PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr
computeExpTip PGSFIOR CoreExpr
md) Type
ty

memoRTIO :: (Expression e) => ExpTrie e -> (Type -> RecompT IO e) -> Type -> RecompT IO e
memoRTIO :: ExpTrie e -> (Type -> RecompT IO e) -> Type -> RecompT IO e
memoRTIO ExpTrie e
fmtref Type -> RecompT IO e
compute Type
ty
    = (Int -> IO (Bag e)) -> RecompT IO e
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ((Int -> IO (Bag e)) -> RecompT IO e)
-> (Int -> IO (Bag e)) -> RecompT IO e
forall a b. (a -> b) -> a -> b
$ \Int
depth -> if Type -> Int -> Bool
forall a p. (Ord a, Num a) => p -> a -> Bool
memocondexp Type
ty Int
depth then ExpTrie e -> (Type -> RecompT IO e) -> Type -> Int -> IO (Bag e)
forall e.
Expression e =>
IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
ensureAtHand ExpTrie e
fmtref Type -> RecompT IO e
compute Type
ty Int
depth 
                                           else RecompT IO e -> Int -> IO (Bag e)
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (Type -> RecompT IO e
compute Type
ty) Int
depth

ensureAtHand :: IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
ensureAtHand IORef (FMType (Array Int [e]))
fmtref Type -> RecompT IO e
compute Type
ty Int
depth
    = do FMType (Array Int [e])
fmt <- IORef (FMType (Array Int [e])) -> IO (FMType (Array Int [e]))
forall a. IORef a -> IO a
readIORef IORef (FMType (Array Int [e]))
fmtref
         case Type -> FMType (Array Int [e]) -> Maybe (Array Int [e])
forall a. Type -> FMType a -> Maybe a
lookupFMT Type
ty FMType (Array Int [e])
fmt of
           Maybe (Array Int [e])
Nothing -> IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
makeAtHand IORef (FMType (Array Int [e]))
fmtref Type -> RecompT IO e
compute Type
ty Int
depth
           Just Array Int [e]
ar | (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Array Int [e] -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int [e]
ar) Int
depth -> [e] -> IO [e]
forall (m :: * -> *) a. Monad m => a -> m a
return ([e] -> IO [e]) -> [e] -> IO [e]
forall a b. (a -> b) -> a -> b
$ Array Int [e]
arArray Int [e] -> Int -> [e]
forall i e. Ix i => Array i e -> i -> e
!Int
depth
                   | Bool
otherwise                 -> IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
makeAtHand IORef (FMType (Array Int [e]))
fmtref Type -> RecompT IO e
compute Type
ty Int
depth

makeAtHand :: IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
makeAtHand IORef (FMType (Array Int [e]))
fmtref Type -> RecompT IO e
compute Type
ty Int
depth = do [e]
result <- RecompT IO e -> Int -> IO [e]
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (Type -> RecompT IO e
compute Type
ty) Int
depth
                                        if Type -> Int -> Bool
forall a p. (Ord a, Num a) => p -> a -> Bool
memocondexp Type
ty (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) then do IORef (FMType (Array Int [e]))
-> (Type -> RecompT IO e) -> Type -> Int -> IO [e]
ensureAtHand IORef (FMType (Array Int [e]))
fmtref Type -> RecompT IO e
compute Type
ty (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
{-
                                                                            modifyIORef fmtref (fst . addToLast ty depth result)
                                                                            return result
-}
                                                                            IORef (FMType (Array Int [e]))
-> (FMType (Array Int [e]) -> (FMType (Array Int [e]), [e]))
-> IO [e]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (FMType (Array Int [e]))
fmtref (Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
forall e.
Expression e =>
Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
addToLast Type
ty Int
depth [e]
result)
{-
                                                                    else do modifyIORef fmtref (fst . mkSingle ty depth result)
                                                                            return result
-}
                                                                    else IORef (FMType (Array Int [e]))
-> (FMType (Array Int [e]) -> (FMType (Array Int [e]), [e]))
-> IO [e]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (FMType (Array Int [e]))
fmtref (Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
forall e.
Expression e =>
Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
mkSingle Type
ty Int
depth [e]
result)
-- exptipをlookupするときもnormalizeすべき．と思ったけど，typetipにあるtypeはnormalizeされてる．

addToLast :: Expression e => Type -> Int -> [e] -> FMType (Array Int [e]) -> (FMType (Array Int [e]), [e])
addToLast :: Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
addToLast Type
ty Int
depth [e]
result FMType (Array Int [e])
fmt = ((Array Int [e] -> Array Int [e])
-> Array Int [e]
-> Type
-> FMType (Array Int [e])
-> FMType (Array Int [e])
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT Array Int [e] -> Array Int [e]
upd (String -> Array Int [e]
forall a. HasCallStack => String -> a
error String
"addToLast: cannot happen") Type
ty FMType (Array Int [e])
fmt, [e]
result)
    where upd :: Array Int [e] -> Array Int [e]
upd Array Int [e]
ar = (Int, Int) -> [(Int, [e])] -> Array Int [e]
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
lo,Int
depth) ((Int
depth,[e]
result) (Int, [e]) -> [(Int, [e])] -> [(Int, [e])]
forall a. a -> [a] -> [a]
: Array Int [e] -> [(Int, [e])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int [e]
ar)
                   where (Int
lo,Int
_hi) = Array Int [e] -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int [e]
ar
mkSingle :: Expression e => Type -> Int -> [e] -> FMType (Array Int [e]) -> (FMType (Array Int [e]), [e])
mkSingle :: Type
-> Int
-> [e]
-> FMType (Array Int [e])
-> (FMType (Array Int [e]), [e])
mkSingle Type
ty Int
depth [e]
result FMType (Array Int [e])
fmt = ((Array Int [e] -> Array Int [e])
-> Array Int [e]
-> Type
-> FMType (Array Int [e])
-> FMType (Array Int [e])
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT (String -> Array Int [e] -> Array Int [e]
forall a. HasCallStack => String -> a
error String
"mkSingle: I think this cannot happen") ((Int, Int) -> [(Int, [e])] -> Array Int [e]
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
depth,Int
depth) [(Int
depth,[e]
result)]) Type
ty FMType (Array Int [e])
fmt, [e]
result)


{-
modify :: Type -> Int -> FMType (Array Int [AnnExpr]) -> (FMType (Array Int [AnnExpr]), [AnnExpr])
modify ty depth fmt
    = case lookupFMT fmt ty of
        Nothing -> do result <- compute  ってことは, IO が間に入るので, atomic ではない.

atomicかどうかは後で考える．

要は，
・該当箇所がmemo対象でない場合，computeして終了．
            memo対象の場合(X)，memoにあるなら，それを取ってきて終了．
                                     ないのであれば，{result <- compute;
                                                      該当箇所の1個浅いところがmemo対象でない場合，該当箇所のみをもつsingleton arrayを書き込んで終了(A)
                                                                               memo対象なら，{(X)を１こ浅いところで実行（結果は捨て）;
                                                                                              （１個浅いところまでのarrayができてるので，）該当箇所を末尾に加えて終了(B)}}

atomicallyにやるのは(A)と(B)だけか．atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b
実はmemocondexpで(memodepthなしで)できそう．
関数(X)が本質的．loopするので．(X)をensureAtHandという名前に．
-}



-- entry for memoization
matchFunctionsIO :: PGSFIOR CoreExpr -> Type -> DBoundT IO CoreExpr
matchFunctionsIO :: PGSFIOR CoreExpr -> Type -> DBoundT IO CoreExpr
matchFunctionsIO PGSFIOR CoreExpr
memodeb Type
ty = case Type -> ([Type], Type)
splitArgs (Type -> Type
saferQuantify Type
ty) of ([Type]
avail,Type
t) -> PGSFIOR CoreExpr -> [Type] -> Type -> DBoundT IO CoreExpr
matchFunsIO PGSFIOR CoreExpr
memodeb [Type]
avail Type
t

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

matchFunsIO :: PGSFIOR CoreExpr -> [Type] -> Type -> DBoundT IO CoreExpr
matchFunsIO :: PGSFIOR CoreExpr -> [Type] -> Type -> DBoundT IO CoreExpr
matchFunsIO PGSFIOR CoreExpr
memodeb [Type]
avail Type
reqret = DBoundT IO [CoreExpr] -> DBoundT IO CoreExpr
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (DBoundT IO [CoreExpr] -> DBoundT IO CoreExpr)
-> DBoundT IO [CoreExpr] -> DBoundT IO CoreExpr
forall a b. (a -> b) -> a -> b
$ PriorSubsts (DBoundT IO) [CoreExpr] -> DBoundT IO [CoreExpr]
forall (m :: * -> *) a. Monad m => PriorSubsts m a -> m a
runPS (Generator (DBoundT IO) CoreExpr -> Generator (DBoundT IO) CoreExpr
forall (m :: * -> *).
Search m =>
Generator m CoreExpr -> Generator m CoreExpr
matchFuns' Generator (DBoundT IO) CoreExpr
unifyableExprsIO PGSFIOR CoreExpr
memodeb [Type]
avail Type
reqret)

matchFuns' :: (Search m) => Generator m CoreExpr -> Generator m CoreExpr
-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ．
matchFuns' :: Generator m CoreExpr -> Generator m CoreExpr
matchFuns' Generator m CoreExpr
rec md :: PGSFIOR CoreExpr
md@(PGSFIOR IORef (FMType (Array Int [CoreExpr]))
_ (CL MemoDeb (ClassLib CoreExpr) CoreExpr
classLib, TypeTrie
_, (([[Prim]], [[Prim]])
_,([[Prim]]
primgen,[[Prim]]
primmono)),Common
cmn)) [Type]
avail Type
reqret
    = let clbehalf :: Type -> PriorSubsts m [CoreExpr]
clbehalf  = Generator m CoreExpr
forall (m :: * -> *). Search m => Generator m CoreExpr
mguPrograms MemoDeb (ClassLib CoreExpr) CoreExpr
classLib []
          behalf :: Type -> PriorSubsts m [CoreExpr]
behalf    = Generator m CoreExpr
rec PGSFIOR CoreExpr
md [Type]
avail
          lltbehalf :: Type -> PriorSubsts m [CoreExpr]
lltbehalf = Int -> Generator m CoreExpr -> Generator m CoreExpr
forall (m :: * -> *) e.
(Search m, Expression e) =>
Int -> Generator m e -> Generator m e
lookupListrie Int
lenavails Generator m CoreExpr
rec PGSFIOR CoreExpr
md [Type]
avail -- heuristic filtration
          lenavails :: Int
lenavails = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail
--          fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration
          fe :: Type -> Type -> [CoreExpr] -> [CoreExpr]
fe        = Bool -> Type -> Type -> [CoreExpr] -> [CoreExpr]
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
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> [Type]
-> PriorSubsts m [CoreExpr]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> [Type]
-> PriorSubsts m [e]
fromAssumptions Common
cmn Int
lenavails Type -> PriorSubsts m [CoreExpr]
behalf (\Type
a Type
b -> Bool -> PriorSubsts m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts m ()) -> Bool -> PriorSubsts m ()
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 m [CoreExpr]
-> PriorSubsts m [CoreExpr] -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
          (Prim -> PriorSubsts m [CoreExpr])
-> [[Prim]] -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum (Common
-> Int
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> Prim
-> PriorSubsts m [CoreExpr]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> Prim
-> PriorSubsts m [e]
retPrimMono Common
cmn Int
lenavails Type -> PriorSubsts m [CoreExpr]
clbehalf Type -> PriorSubsts m [CoreExpr]
lltbehalf Type -> PriorSubsts m [CoreExpr]
behalf Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
matchPS Type
reqret) [[Prim]]
primmono PriorSubsts m [CoreExpr]
-> PriorSubsts m [CoreExpr] -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
          (Prim -> PriorSubsts m [CoreExpr])
-> [[Prim]] -> PriorSubsts m [CoreExpr]
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
-> (Type -> Type -> [CoreExpr] -> [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> Type
-> Prim
-> PriorSubsts m [CoreExpr]
forall (n :: * -> *) e j i b c.
(Search n, Expression e, Integral j, Integral i) =>
Common
-> i
-> (Type -> Type -> [e] -> b)
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> (j, j, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n b
retGenTV0 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
-> (Type -> Type -> [CoreExpr] -> [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> Type
-> Prim
-> PriorSubsts m [CoreExpr]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
retGenTV1 else Common
-> Int
-> (Type -> Type -> [CoreExpr] -> [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> (Type -> PriorSubsts m [CoreExpr])
-> Type
-> Prim
-> PriorSubsts m [CoreExpr]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
retGenOrd) Common
cmn Int
lenavails Type -> Type -> [CoreExpr] -> [CoreExpr]
fe Type -> PriorSubsts m [CoreExpr]
clbehalf Type -> PriorSubsts m [CoreExpr]
lltbehalf Type -> PriorSubsts m [CoreExpr]
behalf Type
reqret) [[Prim]]
primgen

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 memodeb :: PGSFIOR e
memodeb@(PGSFIOR ExpTrie e
_ (ClassLib e
_,TypeTrie
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn)) [Type]
avail Type
t
                                    | Opt () -> Bool
forall a. Opt a -> Bool
constrL Opt ()
opts = Common -> Int -> Type -> [Type] -> PriorSubsts m [e]
forall (m :: * -> *) e.
(Functor m, MonadPlus m, Expression e) =>
Common -> Int -> Type -> [Type] -> PriorSubsts m [e]
matchAssumptions Common
cmn Int
lenavails Type
t [Type]
avail
                                    | Opt () -> Bool
forall a. Opt a -> Bool
guess Opt ()
opts = do
                                       [e]
args <- Generator m e
rec PGSFIOR 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] -> PriorSubsts m [e]
forall (m :: * -> *) a. Monad m => a -> m a
return [e]
args'
                                    | Bool
otherwise = do
                                       [e]
args <- Generator m e
rec PGSFIOR 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] -> PriorSubsts m [e]
forall (m :: * -> *) a. Monad m => a -> m a
return [e]
args'
    where opts :: Opt ()
opts = Common -> Opt ()
opt Common
cmn

\end{code}