-- 
-- (c) Susumu Katayama
--

\begin{code}
{-# OPTIONS -cpp #-}

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

import MagicHaskeller.Instantiate

import MagicHaskeller.Expression

import MagicHaskeller.T10
import qualified Data.Map as Map

import Debug.Trace

import System.Random

import MagicHaskeller.MyDynamic

import qualified MagicHaskeller.PolyDynamic as PD

import MagicHaskeller.Options

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

-- replacement of LISTENER. Now replaced further with |guess|
-- listen = False

-- | annotated 'Typed [CoreExpr]'
type Prim = (Int, Int, Type, TyVar, Typed [CoreExpr])

class WithCommon a where
    extractCommon :: a -> Common

-- | ProgramGenerator is a generalization of the old @Memo@ type. 
class WithCommon a => ProgramGenerator a where
    -- | |mkTrie| creates the generator with the default parameters.
    mkTrie :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> a
    mkTrie Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t = Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
forall a.
ProgramGenerator a =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkTrieOpt Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t [[Typed [CoreExpr]]]
t
    mkTrieOpt :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a
    mkTrieOpt Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
_ [[Typed [CoreExpr]]]
t = Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> a
forall a.
ProgramGenerator a =>
Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> a
mkTrie Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t
                         -- error "This program generator does not take an optional primitive set."
    matchingPrograms, matchingProgramsWOAbsents, unifyingPrograms :: Search m => Type -> a -> m AnnExpr
    matchingPrograms Type
ty a
memodeb = Type -> a -> m AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
unifyingPrograms (Type -> Type
quantify Type
ty) a
memodeb
    matchingProgramsWOAbsents Type
ty a
memodeb = (Bag AnnExpr -> Bag AnnExpr) -> m AnnExpr -> m AnnExpr
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth ((AnnExpr -> Bool) -> Bag AnnExpr -> Bag AnnExpr
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (AnnExpr -> Bool) -> AnnExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CoreExpr -> Bool
isAbsent (Type -> Int
forall i. Integral i => Type -> i
getArity Type
ty) (CoreExpr -> Bool) -> (AnnExpr -> CoreExpr) -> AnnExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnExpr -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE)) (m AnnExpr -> m AnnExpr) -> m AnnExpr -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ Type -> a -> m AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
matchingPrograms Type
ty a
memodeb
class WithCommon a => ProgramGeneratorIO a where
    -- | |mkTrie| creates the generator with the default parameters.
    mkTrieIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> IO a
    mkTrieIO Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t = Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO a
forall a.
ProgramGeneratorIO a =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO a
mkTrieOptIO Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t [[Typed [CoreExpr]]]
t
    mkTrieOptIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO a
    mkTrieOptIO Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
_ [[Typed [CoreExpr]]]
t = Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> IO a
forall a.
ProgramGeneratorIO a =>
Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> IO a
mkTrieIO Common
cmn [Typed [CoreExpr]]
c [[Typed [CoreExpr]]]
t
                         -- error "This program generator does not take an optional primitive set."
    -- | Use memoization requiring IO
    matchingProgramsIO, unifyingProgramsIO :: Type -> a -> RecompT IO AnnExpr -- Should I define SearchT?
    matchingProgramsIO Type
ty a
memodeb = Type -> a -> RecompT IO AnnExpr
forall a. ProgramGeneratorIO a => Type -> a -> RecompT IO AnnExpr
unifyingProgramsIO (Type -> Type
quantify Type
ty) a
memodeb
    -- Another option might be to create @newtype MemoToFile = NT (RecompT (StateT Params IO))@, and define @instance Search MemoToFile@. One drawback of this approach is that @Params@ is separated from @Options@.  
extractTCL :: WithCommon a => a -> TyConLib
extractTCL :: a -> TyConLib
extractTCL = Common -> TyConLib
tcl (Common -> TyConLib) -> (a -> Common) -> a -> TyConLib
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Common
forall a. WithCommon a => a -> Common
extractCommon
extractVL :: WithCommon a => a -> VarLib
extractVL :: a -> VarLib
extractVL = Common -> VarLib
vl (Common -> VarLib) -> (a -> Common) -> a -> VarLib
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Common
forall a. WithCommon a => a -> Common
extractCommon
extractRTrie :: WithCommon a => a -> RTrie
extractRTrie :: a -> RTrie
extractRTrie = Common -> RTrie
rt (Common -> RTrie) -> (a -> Common) -> a -> RTrie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Common
forall a. WithCommon a => a -> Common
extractCommon
reducer :: Common -> CoreExpr -> Dynamic
reducer :: Common -> CoreExpr -> Dynamic
reducer Common
cmn = Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)

data Common = Cmn {Common -> Opt ()
opt :: Opt (), Common -> TyConLib
tcl :: TyConLib, Common -> VarLib
vl :: VarLib, Common -> VarLib
pvl :: VarLib, Common -> VarPriorityLib
vpl :: VarPriorityLib, Common -> RTrie
rt :: RTrie}

mkCommon :: Options -> [Primitive] -> [Primitive] -> [Int] -> Common
mkCommon :: Options -> [Primitive] -> [Primitive] -> [Int] -> Common
mkCommon Options
opts [Primitive]
totals [Primitive]
partials [Int]
priorities
    = let cmn :: Common
cmn = Options -> [Primitive] -> Common
initCommon Options
opts [Primitive]
totals in
      [Dynamic] -> [Dynamic] -> [Int] -> Common -> Common
updateCommon ((Primitive -> Dynamic) -> [Primitive] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Primitive -> Dynamic
primitiveToDynamic (TyConLib -> Primitive -> Dynamic)
-> TyConLib -> Primitive -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) [Primitive]
totals) ((Primitive -> Dynamic) -> [Primitive] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Primitive -> Dynamic
primitiveToDynamic (TyConLib -> Primitive -> Dynamic)
-> TyConLib -> Primitive -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) [Primitive]
partials) [Int]
priorities Common
cmn
initCommon :: Options -> [Primitive] -> Common
initCommon :: Options -> [Primitive] -> Common
initCommon = (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> Options
-> [Primitive]
-> Common
initCommonExt (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat [])
initCommonExt :: (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> Options -> [Primitive] -> Common
initCommonExt :: (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> Options
-> [Primitive]
-> Common
initCommonExt TyConLib -> [[(String, Dynamic)]]
cmpExt TyConLib -> [[(String, Dynamic)]]
arbExt TyConLib -> [[(String, Dynamic)]]
coarbExt Options
opts [Primitive]
totals = let
                           tyconlib :: TyConLib
tyconlib = [Primitive] -> TyConLib
primitivesToTCL [Primitive]
totals
                           optunit :: Opt ()
optunit  = Options -> Opt ()
forall a. Opt a -> Opt ()
forget Options
opts
  in Cmn :: Opt ()
-> TyConLib
-> VarLib
-> VarLib
-> VarPriorityLib
-> RTrie
-> Common
Cmn {opt :: Opt ()
opt = Opt ()
optunit, tcl :: TyConLib
tcl = TyConLib
tyconlib, rt :: RTrie
rt = [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [Int]
-> TyConLib
-> Generator
-> RTrie
mkRandTrieExt (TyConLib -> [[(String, Dynamic)]]
cmpExt TyConLib
tyconlib) (TyConLib -> [[(String, Dynamic)]]
arbExt TyConLib
tyconlib) (TyConLib -> [[(String, Dynamic)]]
coarbExt TyConLib
tyconlib) (Options -> [Int]
forall a. Opt a -> [Int]
nrands Options
opts) TyConLib
tyconlib (Options -> Generator
forall a. Opt a -> Generator
stdgen Options
opts)}
-- | 'updateCommon' can be used for incremetal learning
updateCommon :: [PD.Dynamic] -> [PD.Dynamic] -> [Int] -> Common -> Common
updateCommon :: [Dynamic] -> [Dynamic] -> [Int] -> Common -> Common
updateCommon [Dynamic]
totals [Dynamic]
partials [Int]
priorities Common
cmn = Common
cmn{vl :: VarLib
vl = [Dynamic] -> VarLib
dynamicsToVL [Dynamic]
totals, pvl :: VarLib
pvl = [Dynamic] -> VarLib
dynamicsToVL [Dynamic]
partials, vpl :: VarPriorityLib
vpl = [Int] -> VarPriorityLib
prioritiesToVPL [Int]
priorities}

-- | options for limiting the hypothesis space.
type Options = Opt [[Primitive]]

retsTVar :: (a, b, Type, d, e) -> Bool
retsTVar (a
_, b
_, TV TyVar
tv, d
_, e
_) = Bool
True
retsTVar (a, b, Type, d, e)
_                   = Bool
False

annotateTCEs :: Typed [CoreExpr] -> Prim
annotateTCEs :: Typed [CoreExpr] -> Prim
annotateTCEs tx :: Typed [CoreExpr]
tx@([CoreExpr]
_:::Type
t) = let (Int
numcs, Int
arity, Type
retty) = Type -> (Int, Int, Type)
forall i. Integral i => Type -> (i, i, Type)
getAritiesRet Type
t
                          in (Int
numcs, Int
arity, Type
retty, Type -> TyVar
maxVarID Type
t TyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+ TyVar
1, Typed [CoreExpr]
tx) -- arity is the shorter arity that does not count contexts.

splitPrims :: [Typed [CoreExpr]] -> ([Prim],[Prim])
splitPrims :: [Typed [CoreExpr]] -> ([Prim], [Prim])
splitPrims = (Prim -> Bool) -> [Prim] -> ([Prim], [Prim])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Prim -> Bool
forall a b d e. (a, b, Type, d, e) -> Bool
retsTVar ([Prim] -> ([Prim], [Prim]))
-> ([Typed [CoreExpr]] -> [Prim])
-> [Typed [CoreExpr]]
-> ([Prim], [Prim])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Typed [CoreExpr] -> Prim) -> [Typed [CoreExpr]] -> [Prim]
forall a b. (a -> b) -> [a] -> [b]
map Typed [CoreExpr] -> Prim
annotateTCEs

splitPrimss :: [[Typed [CoreExpr]]] -> ([[Prim]],[[Prim]])
splitPrimss :: [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss = [([Prim], [Prim])] -> ([[Prim]], [[Prim]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Prim], [Prim])] -> ([[Prim]], [[Prim]]))
-> ([[Typed [CoreExpr]]] -> [([Prim], [Prim])])
-> [[Typed [CoreExpr]]]
-> ([[Prim]], [[Prim]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Typed [CoreExpr]] -> ([Prim], [Prim]))
-> [[Typed [CoreExpr]]] -> [([Prim], [Prim])]
forall a b. (a -> b) -> [a] -> [b]
map [Typed [CoreExpr]] -> ([Prim], [Prim])
splitPrims

{-
splitPrimss :: Search m => [[Typed [CoreExpr]]] -> (m Prim, m Prim)
splitPrimss pss = case unzip $ map splitPrims pss of (pssf, psss) -> (fromMx $ Mx pssf, fromMx $ Mx psss)
-}

mapSum :: (MonadPlus m, Delay m) => (a -> m b) -> [[a]] -> m b
mapSum :: (a -> m b) -> [[a]] -> m b
mapSum a -> m b
f = ([a] -> m b -> m b) -> m b -> [[a]] -> m b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[a]
xs m b
y -> [m b] -> m b
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((a -> m b) -> [a] -> [m b]
forall a b. (a -> b) -> [a] -> [b]
map a -> m b
f [a]
xs) m b -> m b -> m b
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` m b -> m b
forall (m :: * -> *) a. Delay m => m a -> m a
delay m b
y) m b
forall (m :: * -> *) a. MonadPlus m => m a
mzero 


-- avail$B$K$7$m(BType$B$K$7$m(Bapply$B$5$l$F$$$k!%(B
-- $B$@$+$i$3$=!$(BrunAnotherPS$BE*$K(BemptySubst$B$KBP$7$F<B9T$7$?J}$,8zN(E*$J$O$:!)(B $B$G$b!$(BSubstitution$B$C$F$=$s$J$K$G$+$/$J$i$J$+$C$?$N$G$O!)(BFiniteMap$B$G$b(Bassoc list$B$G$bJQ$o$i$J$+$C$?5$$,!%(B


applyDo :: (Functor m, Monad m) => ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a
applyDo :: ([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo [Type] -> Type -> PriorSubsts m a
fun [Type]
avail Type
ty = do Subst
subst <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                          [Type] -> Type -> PriorSubsts m a
fun ((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
ty)

wind :: (a->a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind :: (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind a -> a
g [Type] -> Type -> a
f [Type]
avail (Type
t0 :-> Type
t1) = a -> a
g (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind a -> a
g [Type] -> Type -> a
f (Type
t0 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
avail) Type
t1
wind a -> a
_ [Type] -> Type -> a
f [Type]
avail Type
reqret      = [Type] -> Type -> a
f [Type]
avail Type
reqret

wind_ :: ([Type] -> Type -> a) -> [Type] -> Type -> a
wind_ :: ([Type] -> Type -> a) -> [Type] -> Type -> a
wind_ = (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind a -> a
forall a. a -> a
id


{-# SPECIALIZE fromAssumptions :: (Search m) => Common -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}
fromAssumptions :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [e]
fromAssumptions :: Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> [Type]
-> PriorSubsts m [e]
fromAssumptions Common
cmn Int
lenavails Type -> PriorSubsts m [e]
behalf Type -> Type -> PriorSubsts m ()
mps Type
reqret [Type]
avail = [PriorSubsts m [e]] -> PriorSubsts m [e]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m [e]] -> PriorSubsts m [e])
-> [PriorSubsts m [e]] -> PriorSubsts m [e]
forall a b. (a -> b) -> a -> b
$ ((TyVar, (Int, [Type], Type)) -> PriorSubsts m [e])
-> [(TyVar, (Int, [Type], Type))] -> [PriorSubsts m [e]]
forall a b. (a -> b) -> [a] -> [b]
map (Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ())
-> (TyVar, (Int, [Type], Type))
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ())
-> (TyVar, (Int, [Type], Type))
-> PriorSubsts m [e]
retMono Common
cmn Int
lenavails Type -> PriorSubsts m [e]
behalf ((Type -> Type -> PriorSubsts m ())
-> Type -> Type -> PriorSubsts m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> PriorSubsts m ()
mps Type
reqret)) ([Type] -> [(TyVar, (Int, [Type], Type))]
fromAvail [Type]
avail)

retMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> (Int8, (Int,[Type],Type)) -> PriorSubsts m [e]
retMono :: Common
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ())
-> (TyVar, (Int, [Type], Type))
-> PriorSubsts m [e]
retMono Common
cmn Int
lenavails Type -> PriorSubsts m [e]
behalf Type -> PriorSubsts m ()
tok (TyVar, (Int, [Type], Type))
fromBlah
                  = do let (TyVar
n, (Int
arity,[Type]
args,Type
retty)) = (TyVar, (Int, [Type], Type))
fromBlah
                       Type -> PriorSubsts m ()
tok Type
retty
                       (m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> PriorSubsts m [e] -> PriorSubsts m [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
arity) (PriorSubsts m [e] -> PriorSubsts m [e])
-> PriorSubsts m [e] -> PriorSubsts m [e]
forall a b. (a -> b) -> a -> b
$
                              (Type -> PriorSubsts m [e]) -> [Type] -> [e] -> PriorSubsts m [e]
forall (t :: * -> *) (m :: * -> *) (m :: * -> *) r t.
(Foldable t, Monad m, Monad m, Expression r) =>
(t -> m (m r)) -> t t -> m r -> m (m r)
fap Type -> PriorSubsts m [e]
behalf [Type]
args ((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
0 Int
arity) [TyVar -> CoreExpr
X TyVar
n])
fromAvail :: [Type] -> [(Int8, (Int,[Type],Type))]
fromAvail :: [Type] -> [(TyVar, (Int, [Type], Type))]
fromAvail = (TyVar -> Type -> (TyVar, (Int, [Type], Type)))
-> [TyVar] -> [Type] -> [(TyVar, (Int, [Type], Type))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ TyVar
n Type
t -> (TyVar
n, Type -> (Int, [Type], Type)
forall i. Integral i => Type -> (i, [Type], Type)
revSplitArgs Type
t)) [TyVar
0..]


-- ConstrL$B$G$O(Bmatch$B$G$O%@%a!%M}M3$O(BDec. 2, 2007$B$N(Bnotes$B$r;2>H!%(B
mguAssumptions :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m [CoreExpr]
mguAssumptions :: Type -> [Type] -> PriorSubsts m [CoreExpr]
mguAssumptions  Type
patty [Type]
assumptions = ([Type] -> Type -> PriorSubsts m [CoreExpr])
-> [Type] -> Type -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo [Type] -> Type -> PriorSubsts m [CoreExpr]
forall (m :: * -> *).
MonadPlus m =>
[Type] -> Type -> PriorSubsts m [CoreExpr]
mguAssumptions' [Type]
assumptions Type
patty
mguAssumptions' :: [Type] -> Type -> PriorSubsts m [CoreExpr]
mguAssumptions' [Type]
assumptions Type
patty = [PriorSubsts m [CoreExpr]] -> PriorSubsts m [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m [CoreExpr]] -> PriorSubsts m [CoreExpr])
-> [PriorSubsts m [CoreExpr]] -> PriorSubsts m [CoreExpr]
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type -> PriorSubsts m [CoreExpr])
-> [TyVar] -> [Type] -> [PriorSubsts m [CoreExpr]]
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 ()
mguPS Type
patty Type
t PriorSubsts m ()
-> PriorSubsts m [CoreExpr] -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [CoreExpr] -> PriorSubsts m [CoreExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyVar -> CoreExpr
X TyVar
n]) [TyVar
0..] [Type]
assumptions

{-# SPECIALIZE matchAssumptions :: (Functor m, MonadPlus m) => Common -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}
matchAssumptions :: (Functor m, MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m [e]
matchAssumptions :: Common -> Int -> Type -> [Type] -> PriorSubsts m [e]
matchAssumptions 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]] -> PriorSubsts m [e]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m [e]] -> PriorSubsts m [e])
-> [PriorSubsts m [e]] -> PriorSubsts m [e]
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type -> PriorSubsts m [e])
-> [TyVar] -> [Type] -> [PriorSubsts m [e]]
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] -> PriorSubsts m [e]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [e] -> PriorSubsts m [e]
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)]) [TyVar
0..] [Type]
assumptions
-- match $B$N>l9g!$DL>o$O(Breqty$B$NJ}$@$1(Bapply subst$B$9$l$P$h$$!%(B

-- not sure if this is more efficient than doing mguAssumptions and returning ().
mguAssumptions_ :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m ()
mguAssumptions_ :: Type -> [Type] -> PriorSubsts m ()
mguAssumptions_  Type
patty [Type]
assumptions = ([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 [Type] -> Type -> PriorSubsts m ()
forall (m :: * -> *).
MonadPlus m =>
[Type] -> Type -> PriorSubsts m ()
mguAssumptions_' [Type]
assumptions Type
patty
mguAssumptions_' :: [Type] -> Type -> PriorSubsts m ()
mguAssumptions_' [Type]
assumptions Type
patty = [PriorSubsts m ()] -> PriorSubsts m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m ()] -> PriorSubsts m ())
-> [PriorSubsts m ()] -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$ (Type -> PriorSubsts m ()) -> [Type] -> [PriorSubsts m ()]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
patty) [Type]
assumptions


{-# SPECIALIZE retPrimMono ::  (Search m) => Common -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-}
retPrimMono :: (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
-> Int
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> Type -> PriorSubsts m ())
-> Type
-> Prim
-> PriorSubsts m [e]
retPrimMono Common
cmn Int
lenavails Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf Type -> Type -> PriorSubsts m ()
mps Type
reqret (Int
numcxts, Int
arity, Type
retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
                                              = do TyVar
tvid <- TyVar -> PriorSubsts m TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
                                                   Type -> Type -> PriorSubsts m ()
mps ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
retty) Type
reqret
                                                   (m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> PriorSubsts m [e] -> PriorSubsts m [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
arity) (PriorSubsts m [e] -> PriorSubsts m [e])
-> PriorSubsts m [e] -> PriorSubsts m [e]
forall a b. (a -> b) -> a -> b
$
                                                             (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
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)
funApSub :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> [e] -> PriorSubsts m [e]
funApSub :: (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub = (e -> e -> e)
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
forall (m :: * -> *) (m :: * -> *) r a2.
(Monad m, Monad m) =>
(r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2))
-> (Type -> m (m a2))
-> Type
-> m r
-> m (m r)
funApSubOp e -> e -> e
forall e. Expression e => e -> e -> e
(<$>)
funApSubOp :: (r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2))
-> (Type -> m (m a2))
-> Type
-> m r
-> m (m r)
funApSubOp r -> a2 -> r
op Type -> m (m a2)
clbehalf Type -> m (m a2)
lltbehalf Type -> m (m a2)
behalf = Type -> m r -> m (m r)
faso
    where faso :: Type -> m r -> m (m r)
faso (Type
t:=>Type
ts) m r
funs
              = do m a2
args <- Type -> m (m a2)
clbehalf Type
t
                   Type -> m r -> m (m r)
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)
          faso (Type
t:> Type
ts) m r
funs
              = do m a2
args <- Type -> m (m a2)
lltbehalf Type
t
                   Type -> m r -> m (m r)
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)
          -- original. 
          faso (Type
t:->Type
ts) m r
funs
              = do m a2
args <- Type -> m (m a2)
behalf Type
t
                   Type -> m r -> m (m r)
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)
          faso Type
_        m r
funs = m r -> m (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return m r
funs
-- original$B$G(BrevGetArgs$B7PM3$K$9$k$H!$(BfoldM$B$r;H$C$?>l9g$HF1$88zN($K$J$k!%(B
{-
funApSub behalf t funs = fap behalf (revGetArgs t) funs
revGetArgs (t:->u) = t : revGetArgs u
revGetArgs _       = []
-}
{-
fap behalf (t:ts) funs = do args <- behalf t
                            fap behalf ts (liftM2 (<$>) funs args)
fap _      _      funs = return funs
-}
{- mapM$B$r;H$&(B $B0lHVCY$$!%(B
fap behalf ts funs = do args <- mapM behalf ts
                        return (foldl (liftM2 (<$>)) funs args)
-}
 -- foldM$B$r;H$&!%$J$<$+$3$l$,0lHVB.$$(B
fap :: (t -> m (m r)) -> t t -> m r -> m (m r)
fap t -> m (m r)
behalf t t
ts m r
funs = (m r -> t -> m (m r)) -> m r -> t t -> m (m r)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\m r
fs t
t -> do m r
args <- t -> m (m r)
behalf t
t
                                        m r -> m (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r -> m (m r)) -> m r -> m (m r)
forall a b. (a -> b) -> a -> b
$ (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)
                           m r
funs
                           t t
ts

-- fap behalf ts funs = mapAndFoldM (liftM2 (<$>)) funs behalf ts
mapAndFoldM :: (t -> t -> t) -> t -> (t -> m t) -> [t] -> m t
mapAndFoldM t -> t -> t
op t
n t -> m t
f []     = t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return t
n
mapAndFoldM t -> t -> t
op t
n t -> m t
f (t
x:[t]
xs) = do t
y <- t -> m t
f t
x
                               (t -> t -> t) -> t -> (t -> m t) -> [t] -> m t
mapAndFoldM t -> t -> t
op (t
n t -> t -> t
`op` t
y) t -> m t
f [t]
xs



{-# SPECIALIZE retGen :: (Search m) => Common -> Int -> (Type -> Type -> [CoreExpr] -> [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-}
retGen, retGenOrd, retGenTV1
    :: (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]
retGen :: Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
retGen Common
cmn Int
lenavails Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf = (Type -> [e] -> PriorSubsts m [e])
-> Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
forall (n :: * -> *) e i t b c.
(Search n, Expression e, Integral i) =>
(Type -> t -> PriorSubsts n b)
-> Common
-> i
-> (Type -> Type -> [e] -> t)
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n b
retGen' ((Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf) Common
cmn Int
lenavails Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf
retGen' :: (Type -> t -> PriorSubsts n b)
-> Common
-> i
-> (Type -> Type -> [e] -> t)
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n b
retGen' Type -> t -> PriorSubsts n b
fas Common
cmn i
lenavails Type -> Type -> [e] -> t
fe Type -> PriorSubsts n [e]
clbehalf Type -> PriorSubsts n [e]
lltbehalf Type -> PriorSubsts n [e]
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
                                          = (n (b, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts n b -> PriorSubsts n b
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar))
-> Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
arity) (PriorSubsts n b -> PriorSubsts n b)
-> PriorSubsts n b -> PriorSubsts n b
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 -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B
                                               --                                                              -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B
                                               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
                                               [e]
exprs <- (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> [e]
-> PriorSubsts n [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts n [e]
clbehalf Type -> PriorSubsts n [e]
lltbehalf Type -> PriorSubsts n [e]
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)
                                               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) -- $B$3$NJU$N(Bcheck$B$r(BTVn$B$KF~$kA0$NAa$$CJ3,$K$d$k$N$O(B1$B$D$N9M$(J}$@$,!$(BTVn$BCf$K(Breplace$B$5$l$?$j$O$7$J$$$N$+(B?
                                               Type -> t -> PriorSubsts n b
fas Type
gentvar (Type -> Type -> [e] -> t
fe Type
gentvar Type
ty [e]
exprs)
-- retGenOrd can be used instead of retGen, when not reorganizing.
retGenOrd :: 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 -> [e] -> [e]
fe Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf = (Type -> [e] -> PriorSubsts m [e])
-> Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
forall (n :: * -> *) e i t b c.
(Search n, Expression e, Integral i) =>
(Type -> t -> PriorSubsts n b)
-> Common
-> i
-> (Type -> Type -> [e] -> t)
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n b
retGen' (Bool -> Type -> [e] -> PriorSubsts m [e]
funApSub'' Bool
False) Common
cmn Int
lenavails Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf
    where
--                    funApSub'' filtexp (TV _ :-> _)     funs = mzero -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B....
                    funApSub'' :: Bool -> Type -> [e] -> PriorSubsts m [e]
funApSub'' Bool
filtexp (Type
t:->ts :: Type
ts@(Type
u:->Type
_)) [e]
funs
--                        | t > u     = mzero
                        | Bool
otherwise = do [e]
args  <- Type -> PriorSubsts m [e]
behalf Type
t
                                         Bool -> Type -> [e] -> PriorSubsts m [e]
funApSub'' (Type
tType -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
u) Type
ts (if Bool
filtexp then [ e
f e -> e -> e
forall e. Expression e => e -> e -> e
<$> e
e | e
f <- [e]
funs, e
e <- [e]
args, let CoreExpr
_:$CoreExpr
d = e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE e
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE e
e ]
                                                                         else (e -> e -> e) -> [e] -> [e] -> [e]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 e -> e -> e
forall e. Expression e => e -> e -> e
(<$>) [e]
funs [e]
args)
-- $B$F$f!<$+(Bt$B$H(Bu$B$,F1$8$J$i$P$b$C$H$$$m$s$J$3$H$,$G$-$=$&!%(B
                    funApSub'' Bool
filtexp (Type
t:->Type
ts) [e]
funs
                                    = do [e]
args  <- Type -> PriorSubsts m [e]
behalf Type
t
                                         [e] -> PriorSubsts m [e]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
filtexp then [ e
f e -> e -> e
forall e. Expression e => e -> e -> e
<$> e
e | e
f <- [e]
funs, e
e <- [e]
args, let CoreExpr
_:$CoreExpr
d = e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE e
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE e
e]
                                                            else (e -> e -> e) -> [e] -> [e] -> [e]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 e -> e -> e
forall e. Expression e => e -> e -> e
(<$>) [e]
funs [e]
args)
                    funApSub'' Bool
_fe Type
_t [e]
funs = [e] -> PriorSubsts m [e]
forall (m :: * -> *) a. Monad m => a -> m a
return [e]
funs

orderedAndUsedArgs :: Type -> Bool
orderedAndUsedArgs (TV TyVar
_ :-> Type
_) = Bool
False -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B....
orderedAndUsedArgs (Type
t:->ts :: Type
ts@(Type
u:->Type
_)) | Type
t Type -> Type -> Bool
forall a. Ord a => a -> a -> Bool
> Type
u     = Bool
False
                             | Bool
otherwise = Type -> Bool
orderedAndUsedArgs Type
ts
orderedAndUsedArgs Type
_ = Bool
True

usedArg :: TyVar -> Type -> Bool
usedArg TyVar
n (TV TyVar
m :-> Type
_) = TyVar
n TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
/= TyVar
m
usedArg TyVar
_ Type
_            = Bool
True

retGenTV1 :: Common
-> Int
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> Prim
-> PriorSubsts m [e]
retGenTV1 Common
cmn Int
lenavails Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf Type
reqret (Int
numcxts, Int
arity, Type
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
                                          = (m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> PriorSubsts m [e] -> PriorSubsts m [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar))
-> Int -> m ([e], Subst, TyVar) -> m ([e], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
arity) (PriorSubsts m [e] -> PriorSubsts m [e])
-> PriorSubsts m [e] -> PriorSubsts m [e]
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 -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B
                                               --                                                              -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B
                                               Int
a <- Int -> TyVar -> Type -> PriorSubsts m 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
                                               [e]
exprs <- (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
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
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
a)) [CoreExpr]
xs)
                                               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 (TyVar -> Type -> Bool
usedArg (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) Type
gentvar)
                                               (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts m [e]
clbehalf Type -> PriorSubsts m [e]
lltbehalf Type -> PriorSubsts m [e]
behalf Type
gentvar (Type -> Type -> [e] -> [e]
fe Type
gentvar Type
ty [e]
exprs)

retGenTV0 :: 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 Common
cmn i
lenavails Type -> Type -> [e] -> b
fe Type -> PriorSubsts n [e]
clbehalf Type -> PriorSubsts n [e]
lltbehalf Type -> PriorSubsts n [e]
behalf Type
reqret (j
numcxts, j
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
                                          = (n (b, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts n b -> PriorSubsts n b
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar))
-> Int -> n (b, Subst, TyVar) -> n (b, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ j -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral j
arity) (PriorSubsts n b -> PriorSubsts n b)
-> PriorSubsts n b -> PriorSubsts n b
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 -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B
                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B
                                               --                                                              -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B
                                               Subst -> PriorSubsts n ()
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 n [e])
-> (Type -> PriorSubsts n [e])
-> (Type -> PriorSubsts n [e])
-> Type
-> [e]
-> PriorSubsts n [e]
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m [e])
-> Type
-> [e]
-> PriorSubsts m [e]
funApSub Type -> PriorSubsts n [e]
clbehalf Type -> PriorSubsts n [e]
lltbehalf Type -> PriorSubsts n [e]
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 -> j -> j -> 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 j
numcxts j
arity) [CoreExpr]
xs)
                                               Type
gentvar <- Type -> PriorSubsts n Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
                                               b -> PriorSubsts n b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> PriorSubsts n b) -> b -> PriorSubsts n b
forall a b. (a -> b) -> a -> b
$ Type -> Type -> [e] -> b
fe Type
gentvar Type
ty [e]
exprs

filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e]
filtExprs :: Bool -> Type -> Type -> [e] -> [e]
filtExprs Bool
g Type
a Type
b | Bool
g         = Type -> Type -> [e] -> [e]
forall e. Expression e => Type -> Type -> [e] -> [e]
filterExprs Type
a Type
b
                | Bool
otherwise = [e] -> [e]
forall a. a -> a
id

-- LISTENER$B$+(BDESTRUCTIVE$B$,(Bdefine$B$5$l$F$$$k$H$-$N!$3F%1!<%9$N(Boptimization
filterExprs :: Expression e => Type -> Type -> [e] -> [e]
filterExprs :: Type -> Type -> [e] -> [e]
filterExprs Type
gentvar Type
ty = (e -> Bool) -> [e] -> [e]
forall a. (a -> Bool) -> [a] -> [a]
filter ([CoreExpr] -> Bool
cond ([CoreExpr] -> Bool) -> (e -> [CoreExpr]) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> [CoreExpr]
getArgExprs (CoreExpr -> [CoreExpr]) -> (e -> CoreExpr) -> e -> [CoreExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE)
    where cond :: [CoreExpr] -> Bool
cond [CoreExpr]
es = case Type
gentvar of Type
_:->Type
_ -> Bool -> Bool
not (Type -> [CoreExpr] -> Bool
retSameVal Type
ty [CoreExpr]
es) Bool -> Bool -> Bool
&& Bool -> Bool
not ([CoreExpr] -> Bool
includesStrictArg [CoreExpr]
es) Bool -> Bool -> Bool
&& Type -> [CoreExpr] -> Bool
anyRec Type
ty [CoreExpr]
es Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> [CoreExpr] -> Bool
constEq Type
ty [CoreExpr]
es)
                                    Type
_     -> Bool -> Bool
not (Type -> [CoreExpr] -> Bool
retSameVal Type
ty [CoreExpr]
es) Bool -> Bool -> Bool
&& Bool -> Bool
not ([CoreExpr] -> Bool
includesStrictArg [CoreExpr]
es)

getArgExprs :: CoreExpr -> [CoreExpr]
getArgExprs CoreExpr
e = CoreExpr -> [CoreExpr] -> [CoreExpr]
gae CoreExpr
e []
gae :: CoreExpr -> [CoreExpr] -> [CoreExpr]
gae (CoreExpr
f:$CoreExpr
e) [CoreExpr]
es = CoreExpr -> [CoreExpr] -> [CoreExpr]
gae CoreExpr
f (CoreExpr
eCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
es)
gae CoreExpr
_      [CoreExpr]
es = [CoreExpr]
es

-- forall w x y. list_para w (\_ -> x) (\c d e f -> e (blah)) = \_ -> x $BE*$J$b$N(B.
constEq :: Type -> [CoreExpr] -> Bool
constEq (Type
t:->Type
u) (e :: CoreExpr
e@(Lambda CoreExpr
d):[CoreExpr]
es) | Type -> Bool
returnsAtoA Type
t = Type -> CoreExpr -> Bool
recHead Type
t CoreExpr
e Bool -> Bool -> Bool
&& Type -> [CoreExpr] -> Bool
constEq Type
u [CoreExpr]
es
                                  | Bool
otherwise     = Bool -> Bool
not (TyVar -> CoreExpr -> Bool
isUsed TyVar
0 CoreExpr
d) Bool -> Bool -> Bool
&& CoreExpr -> Type -> [CoreExpr] -> Bool
ceq CoreExpr
e Type
u [CoreExpr]
es
constEq (Type
t:->Type
u) (CoreExpr
_:[CoreExpr]
_)             = Bool
False -- not case/cata/para, so should pass.
constEq (Type
_:> Type
u) (CoreExpr
_           :[CoreExpr]
es) = Type -> [CoreExpr] -> Bool
constEq Type
u [CoreExpr]
es
constEq Type
_       []                = Bool
True
ceq :: CoreExpr -> Type -> [CoreExpr] -> Bool
ceq CoreExpr
d (Type
t:->Type
u) (e :: CoreExpr
e@(Lambda CoreExpr
_):[CoreExpr]
es) | Type -> Bool
returnsAtoA Type
t = Type -> CoreExpr -> Bool
recHead Type
t CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Type -> [CoreExpr] -> Bool
ceq CoreExpr
d Type
u [CoreExpr]
es
                                | Bool
otherwise     = CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreExpr
e      Bool -> Bool -> Bool
&& CoreExpr -> Type -> [CoreExpr] -> Bool
ceq CoreExpr
d Type
u [CoreExpr]
es
ceq CoreExpr
d (Type
t:->Type
u) (CoreExpr
_:[CoreExpr]
_)             = Bool
False -- not case/cata/para, so should pass.
ceq CoreExpr
d (Type
_:> Type
u) (CoreExpr
_           :[CoreExpr]
es) = CoreExpr -> Type -> [CoreExpr] -> Bool
ceq CoreExpr
d Type
u [CoreExpr]
es
ceq CoreExpr
_ Type
_       []                = Bool
True

recHead :: Type -> CoreExpr -> Bool
recHead (Type
t:->u :: Type
u@(Type
_:->Type
_))     (Lambda CoreExpr
e)                   = Type -> CoreExpr -> Bool
recHead Type
u CoreExpr
e
recHead (TV TyVar
tv0 :-> TV TyVar
tv1) (Lambda (Lambda (X TyVar
1 :$ CoreExpr
_))) = TyVar
tv0 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& TyVar
tv1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0   -- $BJ#?t(Brec$B$,$"$k>l9g!$:G8e$NE[$@$1(Brec$B$H$7$FG'$a$k$3$H$K$J$C$A$c$&$N$G!$:GE,2=$N0UL#$G$O$A$g$C$H$@$1%6%k(B
recHead Type
_u                  CoreExpr
_e                           = Bool
False


-- windUntilRec$B$C$F$N$,$"$l$P6&M-2DG=(B (CPS$B$J46$8(B)



retSameVal :: Type -> [CoreExpr] -> Bool
retSameVal (Type
_:>Type
u)  (CoreExpr
_:[CoreExpr]
es) = Type -> [CoreExpr] -> Bool
retSameVal Type
u [CoreExpr]
es
retSameVal (Type
t:->Type
u) (CoreExpr
e:[CoreExpr]
es) = (Type -> CoreExpr -> Bool
returnsId Type
t CoreExpr
e Bool -> Bool -> Bool
&& Type -> [CoreExpr] -> Bool
rsv Type
u [CoreExpr]
es) Bool -> Bool -> Bool
|| CoreExpr -> Type -> [CoreExpr] -> Bool
rsv' (Type -> CoreExpr -> CoreExpr
retVal Type
t CoreExpr
e) Type
u [CoreExpr]
es
retSameVal Type
_       [CoreExpr]
_      = Bool
False
rsv :: Type -> [CoreExpr] -> Bool
rsv (Type
_:>Type
u)  (CoreExpr
_:[CoreExpr]
es) = Type -> [CoreExpr] -> Bool
rsv Type
u [CoreExpr]
es
rsv (Type
t:->Type
u) (CoreExpr
e:[CoreExpr]
es) = (Type -> CoreExpr -> Bool
returnsId Type
t CoreExpr
e Bool -> Bool -> Bool
&& Type -> [CoreExpr] -> Bool
rsv Type
u [CoreExpr]
es) Bool -> Bool -> Bool
|| CoreExpr -> Type -> [CoreExpr] -> Bool
rsv' (Type -> CoreExpr -> CoreExpr
retVal Type
t CoreExpr
e) Type
u [CoreExpr]
es
rsv Type
_       [CoreExpr]
_      = Bool
True
rsv' :: CoreExpr -> Type -> [CoreExpr] -> Bool
rsv' CoreExpr
rve (Type
_:>Type
u)  (CoreExpr
_:[CoreExpr]
es) = CoreExpr -> Type -> [CoreExpr] -> Bool
rsv' CoreExpr
rve Type
u [CoreExpr]
es
rsv' CoreExpr
rve (Type
t:->Type
u) (CoreExpr
e:[CoreExpr]
es) = (Type -> CoreExpr -> Bool
returnsId Type
t CoreExpr
e Bool -> Bool -> Bool
|| Type -> CoreExpr -> CoreExpr
retVal Type
t CoreExpr
e CoreExpr -> CoreExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreExpr
rve) Bool -> Bool -> Bool
&& CoreExpr -> Type -> [CoreExpr] -> Bool
rsv' CoreExpr
rve Type
u [CoreExpr]
es
rsv' CoreExpr
_   Type
_       [CoreExpr]
_      = Bool
True



-- returnsAtoA is True when the type returns a->a, where the tvID of a is 0.
returnsAtoA :: Type -> Bool
returnsAtoA (TV TyVar
tv0 :-> TV TyVar
tv1) = TyVar
tv0 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& TyVar
tv1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0
returnsAtoA (Type
t      :-> Type
u)      = Type -> Bool
returnsAtoA Type
u
returnsAtoA Type
_                   = Bool
False

-- $BF1;~$K(BreturnsAtoA$B$b%A%'%C%/$7$F$k$N$b%]%$%s%H!%(B
returnsId :: Type -> CoreExpr -> Bool
returnsId (Type
t:->u :: Type
u@(Type
_:->Type
_))     (Lambda CoreExpr
e)     = Type -> CoreExpr -> Bool
returnsId Type
u CoreExpr
e
returnsId (TV TyVar
tv0 :-> TV TyVar
tv1) CoreExpr
e              = TyVar
tv0 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& TyVar
tv1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& CoreExpr -> Bool
isId CoreExpr
e
returnsId Type
_u                  CoreExpr
_e             = Bool
False -- $B$3$3$G(B(_u,_e)$B$,(B(TV _, Lambda _)$B$C$F$3$H$b$"$jF@$k!%(B_u$B$,(Bt:->u$B$J$N$K(B_e$B$,(BLambda$B$G$J$$$C$F$N$O$"$j$($J$$$+!%(B
{- $B$3$l$@$H!$7k2L$H$7$F:G8e$N0z?t$HJV$jCM$N7?$,F1$8$@$1$I$b$H$b$H$N(BPrim$B>e$G$O0c$&!$$H$$$&2DG=@-$,$"$jF@$k!%(B
returnsId (t:->u) (Lambda e) = returnsId u e
returnsId (_:->_) _          = error "returnsId: impossible"
returnsId (TV tv) (X 0)      = tvID tv == 0
returnsId _u      _e         = False -- $B$3$3$G(B(_u,_e)$B$,(B(TV _, Lambda _)$B$C$F$3$H$b$"$jF@$k!%(B_u$B$,(Bt:->u$B$J$N$K(B_e$B$,(BLambda$B$G$J$$$C$F$N$O$"$j$($J$$$+!%(B
-}

-- isId checks if the argument is eta-equivalent to id, i.e. (Lambda (X 0)). Note that expressions are eta-expanded.
-- for example, isId (Lambda (Lambda (Lambda ((X 2 :$ X 1) :$ X 0)))) is True.
-- There is no need to tell that isId (Lambda ((Lambda (X 0)) :$ X 0)) is True, because this beta-reducible expression would not be synthesized.
isId :: CoreExpr -> Bool
isId CoreExpr
e = TyVar -> CoreExpr -> Bool
isId' TyVar
0 CoreExpr
e
isId' :: TyVar -> CoreExpr -> Bool
isId' TyVar
n (Lambda CoreExpr
e) = TyVar -> CoreExpr -> Bool
isId' (TyVar
nTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
isId' TyVar
n CoreExpr
e          = TyVar -> TyVar -> CoreExpr -> Bool
isId'' TyVar
n TyVar
0 CoreExpr
e
isId'' :: TyVar -> TyVar -> CoreExpr -> Bool
isId'' TyVar
n TyVar
m (CoreExpr
e :$ X TyVar
i) = TyVar
iTyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
==TyVar
m Bool -> Bool -> Bool
&& TyVar -> TyVar -> CoreExpr -> Bool
isId'' TyVar
n (TyVar
mTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
isId'' TyVar
n TyVar
m (X TyVar
i)      = TyVar
iTyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
==TyVar
m Bool -> Bool -> Bool
&& TyVar
n TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
mTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1
isId'' TyVar
_ TyVar
_ CoreExpr
_          = Bool
False


retVal :: Type -> CoreExpr -> CoreExpr
retVal Type
t CoreExpr
e = Type -> TyVar -> CoreExpr -> CoreExpr
rv Type
t TyVar
0 CoreExpr
e
rv :: Type -> TyVar -> CoreExpr -> CoreExpr
rv (Type
_:->Type
t) TyVar
n (Lambda CoreExpr
e) = Type -> TyVar -> CoreExpr -> CoreExpr
rv Type
t (TyVar
nTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
rv (Type
_:->Type
_) TyVar
_ CoreExpr
_          = String -> CoreExpr
forall a. HasCallStack => String -> a
error String
"rv: impossible"
rv Type
_       TyVar
n CoreExpr
e          = TyVar -> CoreExpr -> CoreExpr
mapsub TyVar
n CoreExpr
e

-- mapsub n ~= gmap (subtract n), but I will have to rewrite the definition of CoreExpr to prevent gmap from updating other Ints.
mapsub :: TyVar -> CoreExpr -> CoreExpr
mapsub TyVar
n (X TyVar
m)      = TyVar -> CoreExpr
X (TyVar
mTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
-TyVar
n)
mapsub TyVar
n (CoreExpr
a :$ CoreExpr
b)   = TyVar -> CoreExpr -> CoreExpr
mapsub TyVar
n CoreExpr
a CoreExpr -> CoreExpr -> CoreExpr
:$ TyVar -> CoreExpr -> CoreExpr
mapsub TyVar
n CoreExpr
b
mapsub TyVar
n (Lambda CoreExpr
e) = CoreExpr -> CoreExpr
Lambda (TyVar -> CoreExpr -> CoreExpr
mapsub TyVar
n CoreExpr
e)
mapsub TyVar
n CoreExpr
e          = CoreExpr
e

isConstrExpr :: CoreExpr -> Bool
isConstrExpr (X TyVar
_)      = Bool
False
isConstrExpr (Lambda CoreExpr
_) = Bool
False
isConstrExpr (Context Dictionary
_) = Bool
False
isConstrExpr (CoreExpr
f :$ CoreExpr
_)   = CoreExpr -> Bool
isConstrExpr CoreExpr
f
isConstrExpr (Primitive Var
_) = Bool
False
isConstrExpr (PrimCon Var
_) = Bool
True

isClosed :: CoreExpr -> Bool
isClosed = TyVar -> CoreExpr -> Bool
isClosed' TyVar
0
isClosed' :: TyVar -> CoreExpr -> Bool
isClosed' TyVar
dep (X TyVar
n)      = TyVar
n TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
< TyVar
dep
isClosed' TyVar
dep (Lambda CoreExpr
e) = TyVar -> CoreExpr -> Bool
isClosed' (TyVar
depTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
isClosed' TyVar
dep (CoreExpr
f :$ CoreExpr
e)   = TyVar -> CoreExpr -> Bool
isClosed' TyVar
dep CoreExpr
f Bool -> Bool -> Bool
&& TyVar -> CoreExpr -> Bool
isClosed' TyVar
dep CoreExpr
e
isClosed' TyVar
_   CoreExpr
_          = Bool
True


-- $B8zN($N$3$H$r9M$($k$H!$(BstrictArg$B$O:G=i$K;}$C$F$/$k$3$H$K$J$k!%!J>-MhE*$K$O!$:G=i$K$J$k$h$&$KJB$YJQ$($F(Bgenerate$B$7!$=*$C$F$+$i85$KLa$9$3$H$K$J$k!K(B
-- $B!J>/$J$/$H$b!$:G=i$K(Bexpand$B$9$k!%@)8B$,B?$$$N$GJ,4t$7$K$/$$$+$i!%!K(B
includesStrictArg :: [CoreExpr] -> Bool
includesStrictArg (X TyVar
n : [CoreExpr]
es) = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVar -> CoreExpr -> Bool
isUsed TyVar
n) [CoreExpr]
es
-- case$B$N%G!<%?$J$N$G(BLambda$B$OMh$J$$!%$"$H!$(BQuantify$B$O:G=i$+$i(Bexclude$B$5$l$F$$$k!%$H$$$&$o$1$G!$$3$3$K$O<B:]$K$O(B((_:$_):_)$B$+(B[]$B$7$+Mh$J$$!%(B
-- $B4X?tE,MQ$N>l9g$O$a$s$I$/$5$$$7%A%'%C%/$b%3%9%H$,$+$+$k$N$GAGDL$7$K$9$k!%(B
includesStrictArg [CoreExpr]
_        = Bool
False
{-
includesStrictArg [] = False
includesStrictArg es = case last es of X n  -> any (isUsed n) (init es)
                                       _:$_ -> False -- $B4X?tE,MQ$N>l9g$O$a$s$I$/$5$$$7%A%'%C%/$b%3%9%H$,$+$+$k$N$GAGDL$7$K$9$k!%(B
-- case$B$N%G!<%?$J$N$G(BLambda$B$OMh$J$$!%$"$H!$(BQuantify$B$O:G=i$+$i(Bexclude$B$5$l$F$$$k!%(B
-}

anyRec :: Type -> [CoreExpr] -> Bool
anyRec (Type
_:>Type
t)  (CoreExpr
_:[CoreExpr]
es) = Type -> [CoreExpr] -> Bool
anyRec Type
t [CoreExpr]
es
anyRec (Type
t:->Type
u) (CoreExpr
e:[CoreExpr]
es) = -- trace ("ar: t = "++show t++" and u = "++ show u) $
                    Type -> CoreExpr -> Bool
recursive Type
t CoreExpr
e Bool -> Bool -> Bool
|| Type -> [CoreExpr] -> Bool
anyRec Type
u [CoreExpr]
es
anyRec (Type
_:->Type
_) [CoreExpr]
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"hoge"
anyRec Type
_       []     = Bool
False
{- type$B$NJ}$r$R$C$/$jJV$9>l9g(B
anyRec (hd:tl@(_:_)) (f:$e) = recursive hd e || anyRec tl f
anyRec _             _      = False
-}

recursive :: Type -> CoreExpr -> Bool
recursive (Type
t:->u :: Type
u@(Type
_:->Type
_))     (Lambda CoreExpr
e) = Type -> CoreExpr -> Bool
recursive Type
u CoreExpr
e
recursive (TV TyVar
tv0 :-> TV TyVar
tv1) (Lambda CoreExpr
e) = TyVar
tv0 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& TyVar
tv1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
0 Bool -> Bool -> Bool
&& TyVar -> CoreExpr -> Bool
isUsed TyVar
0 CoreExpr
e Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar -> CoreExpr -> Bool
constRec TyVar
0 CoreExpr
e) -- $B$3$l$@$H!$(Brecursive$B$N$d$D$H(Bnot const.rec$B$N$d$D$,F1$8$G$J$/$F$O$J$i$J$$$,!$$=$N>r7o$OI,MW$+!)(B $B!J(Blist$B$G$d$C$F$$$k8B$j$O5$$K$7$J$/$F$$$$$C$FOC$b$"$k$1$I!K(B
recursive Type
_                   CoreExpr
_          = Bool
False

constRec :: TyVar -> CoreExpr -> Bool
constRec TyVar
dep (Lambda CoreExpr
e) = TyVar -> CoreExpr -> Bool
constRec (TyVar
depTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
constRec TyVar
dep (X TyVar
n :$ CoreExpr
e) | TyVar
n TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
dep = Bool -> Bool
not (TyVar -> CoreExpr -> Bool
belowIsUsed TyVar
n CoreExpr
e)
constRec TyVar
_   CoreExpr
_          = Bool
False
belowIsUsed :: TyVar -> CoreExpr -> Bool
belowIsUsed TyVar
dep (X TyVar
n)      = TyVar
dep TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
> TyVar
n
belowIsUsed TyVar
dep (Lambda CoreExpr
e) = TyVar -> CoreExpr -> Bool
belowIsUsed (TyVar
depTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
belowIsUsed TyVar
dep (CoreExpr
f :$ CoreExpr
e)   = TyVar -> CoreExpr -> Bool
belowIsUsed TyVar
dep CoreExpr
f Bool -> Bool -> Bool
|| TyVar -> CoreExpr -> Bool
belowIsUsed TyVar
dep CoreExpr
e
belowIsUsed TyVar
_   CoreExpr
_          = Bool
False

{-
lastarg (_:->t@(_:->_)) = let Just (la,n) = lastarg t in Just (la, n+1)
lastarg (t:->_)         = Just (t, 1)
lastarg _               = Nothing

isRec n expr = isUsed (-n) expr
-}
isUsed :: TyVar -> CoreExpr -> Bool
isUsed TyVar
dep (X TyVar
n)      = TyVar
depTyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
==TyVar
n
isUsed TyVar
dep (Lambda CoreExpr
e) = TyVar -> CoreExpr -> Bool
isUsed (TyVar
depTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) CoreExpr
e
isUsed TyVar
dep (CoreExpr
f :$ CoreExpr
e)   = TyVar -> CoreExpr -> Bool
isUsed TyVar
dep CoreExpr
f Bool -> Bool -> Bool
|| TyVar -> CoreExpr -> Bool
isUsed TyVar
dep CoreExpr
e
isUsed TyVar
_   CoreExpr
_          = Bool
False


mkSubsts :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts :: Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts Int
n TyVar
tvid Type
reqret  = PriorSubsts m Int
base PriorSubsts m Int -> PriorSubsts m Int -> PriorSubsts m Int
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Int -> PriorSubsts m Int -> PriorSubsts m Int
forall (m :: * -> *) a.
Delay m =>
Int -> PriorSubsts m a -> PriorSubsts m a
ndelayPS Int
n PriorSubsts m Int
recurse
    where base :: PriorSubsts m Int
base    = do Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (TyVar -> Type -> Subst
forall a b. a -> b -> [(a, b)]
unitSubst TyVar
tvid Type
reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B
                                                     -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B
                       Int -> PriorSubsts m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          recurse :: PriorSubsts m Int
recurse = do TyVar
v <- PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
newTVar
                       Int
arity <- Int -> TyVar -> Type -> PriorSubsts m Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts Int
n TyVar
tvid (TyVar -> Type
TV TyVar
v Type -> Type -> Type
:-> Type
reqret)
                       Int -> PriorSubsts m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

mkSubst :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int
mkSubst :: Int -> TyVar -> Type -> PriorSubsts m Int
mkSubst Int
n TyVar
tvid Type
reqret  = PriorSubsts m Int
base PriorSubsts m Int -> PriorSubsts m Int -> PriorSubsts m Int
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Int -> PriorSubsts m Int -> PriorSubsts m Int
forall (m :: * -> *) a.
Delay m =>
Int -> PriorSubsts m a -> PriorSubsts m a
ndelayPS Int
n PriorSubsts m Int
first
    where base :: PriorSubsts m Int
base    = do Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (TyVar -> Type -> Subst
forall a b. a -> b -> [(a, b)]
unitSubst TyVar
tvid Type
reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B
                                                     -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B
                       Int -> PriorSubsts m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          first :: PriorSubsts m Int
first   = do TyVar
v <- PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
newTVar
                       Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (TyVar -> Type -> Subst
forall a b. a -> b -> [(a, b)]
unitSubst TyVar
tvid (TyVar -> Type
TV TyVar
v Type -> Type -> Type
:-> Type
reqret))
                       Int -> PriorSubsts m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
mkRetty :: Type -> (Type, Type)
mkRetty Type
t = (Type -> Type
getRet Type
t, Type
t)
-- getRet (t0:->t1) = getRet t1
-- getRet t         = t

-- MemoStingy$B$H$+$G$O(B
-- reorganize_ :: ([Type] -> PriorSubsts BF ()) -> [Type] -> PriorSubsts BF ()
-- $B$H$7$F;H$o$l$k$N$@$,!$(BG4ip$B$G$O2<5-$N7?$8$c$J$$$H!%(B
reorganizer_ :: ([Type] -> a) -> [Type] -> a
reorganizer_ :: ([Type] -> a) -> [Type] -> a
reorganizer_ [Type] -> a
fun [Type]
avail = [Type] -> a
fun ([Type] -> a) -> [Type] -> a
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type]
forall a. Ord a => [a] -> [a]
uniqSort [Type]
avail


-- moved from T10.hs to make T10 independent of Types

-- hit decides whether to memoize or not.
hit :: Type -> [Type] -> Bool
-- hit ty tys = True -- always memo
-- hit ty tys = areMono (ty:tys) -- memo only tycons ... Subst$B$$$i$J$$$7!$(BavailsToReplacer$B$J$7$G!J(Bnewavail$B$J$7$G!KH=Dj$G$-$k!%$"$H$=$b$=$b!$(BMapType$B$K(Btv$B$d(Beval$B$,$$$i$J$$$7!$(Bencode/decode$B$b$$$i$J$/$J$k!%$?$@!$(Bmonomorphic$B$7$+$i$d$J$$$N$C$F!$$A$g$C$H>/$J2a$.$k5$$b$9$k!%(B
-- hit ty tys = sum (map size (ty:tys)) < 7
-- hit ty tys = sum (map size (ty:tys)) < 2
-- hit ty tys = sum (map size (ty:tys)) < 5
-- hit ty tys = sum (map size (ty:tys)) < 12
hit :: Type -> [Type] -> Bool
hit Type
ty [Type]
tys = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Type -> Int) -> [Type] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Int
size (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
tys)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10


-- areMono = all (null.tyvars)

combs :: t -> [a] -> [[a]]
combs t
0 [a]
xs = [[]]
combs t
n [a]
xs = []  [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [ a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs | a
y:[a]
ys <- [a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs, [a]
zs <- t -> [a] -> [[a]]
combs (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [a]
ys ]
tails :: [a] -> [[a]]
tails []        = []
tails xs :: [a]
xs@(a
_:[a]
ys) = [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
tails [a]
ys


\end{code}