\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
type Prim = (Int, Int, Type, TyVar, Typed [CoreExpr])
class WithCommon a where
:: a -> Common
class WithCommon a => ProgramGenerator a where
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
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
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
matchingProgramsIO, unifyingProgramsIO :: Type -> a -> RecompT IO AnnExpr
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
extractTCL :: WithCommon a => a -> TyConLib
= 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
= 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
= 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 :: [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}
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)
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
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
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..]
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
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)
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
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
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
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)
Type -> t -> PriorSubsts n b
fas Type
gentvar (Type -> Type -> [e] -> t
fe Type
gentvar Type
ty [e]
exprs)
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'' :: Bool -> Type -> [e] -> PriorSubsts m [e]
funApSub'' Bool
filtexp (Type
t:->ts :: Type
ts@(Type
u:->Type
_)) [e]
funs
| 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)
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
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
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
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
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
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
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
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
recHead Type
_u CoreExpr
_e = Bool
False
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 :: 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
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
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 :: 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
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
includesStrictArg [CoreExpr]
_ = Bool
False
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) =
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
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)
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
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)
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)
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)
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
hit :: Type -> [Type] -> Bool
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
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}