{-# LANGUAGE CPP, TupleSections #-}
module Conjure.Expr
( module Data.Express
, module Data.Express.Fixtures
, (>$$<)
, funToVar
, recursexpr
, apparentlyTerminates
, mayNotEvaluateArgument
, applicationOld
, compareSimplicity
, ifFor
, primitiveHoles
, primitiveApplications
, valuesBFS
, holesBFS
, fillBFS
, showEq
, lhs
, rhs
, ($$**)
, ($$|<)
, possibleHoles
, isDeconstructionE
, revaluate
, reval
, enumerateApps
, enumerateAppsFor
, module Conjure.Utils
)
where
import Conjure.Utils
import Data.Express
import Data.Express.Utils.Typeable
import Data.Express.Fixtures hiding ((-==-))
import Data.Dynamic
import Control.Applicative ((<$>))
import Test.LeanCheck (filterT, (\/), delay, productWith, productMaybeWith)
compareSimplicity :: Expr -> Expr -> Ordering
compareSimplicity :: Expr -> Expr -> Ordering
compareSimplicity = (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Expr -> Int) -> Expr -> Expr -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Expr] -> Int) -> (Expr -> [Expr]) -> Expr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr]
values)
(Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Ordering) -> Expr -> Expr -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Expr -> Int) -> Expr -> Expr -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Expr] -> Int) -> (Expr -> [Expr]) -> Expr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr]
vars)
(Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Ordering) -> Expr -> Expr -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (Expr -> Int) -> Expr -> Expr -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Expr] -> Int) -> (Expr -> [Expr]) -> Expr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr]
nubConsts)
funToVar :: Expr -> Expr
funToVar :: Expr -> Expr
funToVar (Expr
ef :$ Expr
ex) = Expr -> Expr
funToVar Expr
ef Expr -> Expr -> Expr
:$ Expr
ex
funToVar ef :: Expr
ef@(Value String
nm Dynamic
_) = String
nm String -> Expr -> Expr
`varAsTypeOf` Expr
ef
recursexpr :: Int -> Expr -> Expr -> Expr
recursexpr :: Int -> Expr -> Expr -> Expr
recursexpr Int
sz Expr
epat = Expr -> Expr
re
where
err :: a
err = String -> a
forall a. HasCallStack => String -> a
error String
"recursexpr: pattern must contain an application of variables"
(Expr
erf:[Expr]
vs) = Expr -> [Expr]
unfoldApp Expr
epat
re :: Expr -> Expr
re Expr
e' | Bool -> Bool
not ((Expr -> Bool) -> [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr -> Bool
isVar (Expr
erfExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
vs)) = Expr
forall a. a
err
| Expr
e Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Expr
e' Bool -> Bool -> Bool
|| Expr -> Int
size Expr
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz = Expr
e
| Bool
otherwise = Expr -> Expr
re Expr
e
where
e :: Expr
e = Expr -> Expr
re1 Expr
e'
re1 :: Expr -> Expr
re1 Expr
e = case Expr -> [Expr]
unfoldApp Expr
e of
[Expr
e] -> Expr
e
(Expr
ef:[Expr]
exs) | Expr
ef Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Expr
erf -> Expr
e' Expr -> [(Expr, Expr)] -> Expr
//- [Expr] -> [Expr] -> [(Expr, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
vs [Expr]
exs
| Bool
otherwise -> [Expr] -> Expr
foldApp ((Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Expr
re1 (Expr
efExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
exs))
apparentlyTerminates :: Expr -> Expr -> Bool
apparentlyTerminates :: Expr -> Expr -> Bool
apparentlyTerminates Expr
eRecursiveCall = Expr -> Bool
at
where
at :: Expr -> Bool
at (Expr
e1 :$ Expr
e2) = (Expr -> Bool
mayNotEvaluateArgument Expr
e1 Bool -> Bool -> Bool
|| Expr -> Bool
at Expr
e2) Bool -> Bool -> Bool
&& Expr -> Bool
at Expr
e1
at Expr
e = Expr
e Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
/= Expr
eRecursiveCall
mayNotEvaluateArgument :: Expr -> Bool
mayNotEvaluateArgument :: Expr -> Bool
mayNotEvaluateArgument (Value String
"if" Dynamic
ce :$ Expr
_ :$ Expr
_) = Bool
True
mayNotEvaluateArgument (Value String
"&&" Dynamic
ce :$ Expr
_) = Bool
True
mayNotEvaluateArgument (Value String
"||" Dynamic
ce :$ Expr
_) = Bool
True
mayNotEvaluateArgument Expr
_ = Bool
False
applicationOld :: Expr -> [Expr] -> Maybe Expr
applicationOld :: Expr -> [Expr] -> Maybe Expr
applicationOld Expr
ff [Expr]
es = Expr -> Maybe Expr
appn Expr
ff
where
appn :: Expr -> Maybe Expr
appn Expr
ff
| Expr -> Bool
isFun Expr
ff = case [Expr
e | Just (Expr
_ :$ Expr
e) <- ((Expr -> Maybe Expr) -> [Expr] -> [Maybe Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Expr
ff Expr -> Expr -> Maybe Expr
$$)) [Expr]
es] of
[] -> Maybe Expr
forall a. Maybe a
Nothing
(Expr
e:[Expr]
_) -> Expr -> Maybe Expr
appn (Expr
ff Expr -> Expr -> Expr
:$ Expr -> Expr
holeAsTypeOf Expr
e)
| Bool
otherwise = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
ff
ifFor :: Typeable a => a -> Expr
ifFor :: a -> Expr
ifFor a
a = String -> (Bool -> a -> a -> a) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"if" (\Bool
p a
x a
y -> if Bool
p then a
x else a
y a -> a -> a
forall a. a -> a -> a
`asTypeOf` a
a)
(>$$<) :: [Expr] -> [Expr] -> [Expr]
[Expr]
exs >$$< :: [Expr] -> [Expr] -> [Expr]
>$$< [Expr]
eys = [Maybe Expr] -> [Expr]
forall a. [Maybe a] -> [a]
catMaybes [Expr
ex Expr -> Expr -> Maybe Expr
$$ Expr
ey | Expr
ex <- [Expr]
exs, Expr
ey <- [Expr]
eys]
primitiveHoles :: [Expr] -> [Expr]
primitiveHoles :: [Expr] -> [Expr]
primitiveHoles [Expr]
prims = [Expr] -> [Expr]
forall a. Ord a => [a] -> [a]
sort ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ [Expr] -> [Expr]
ph [Expr]
hs
where
hs :: [Expr]
hs = [Expr] -> [Expr]
forall a. Eq a => [a] -> [a]
nub ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Expr
holeAsTypeOf [Expr]
prims
ph :: [Expr] -> [Expr]
ph = ([Expr] -> [Expr] -> Bool)
-> ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a. (a -> a -> Bool) -> (a -> a) -> a -> a
iterateUntil [Expr] -> [Expr] -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Expr] -> [Expr]
ps
ps :: [Expr] -> [Expr]
ps [Expr]
es = [Expr] -> [Expr]
forall a. Eq a => [a] -> [a]
nub ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ [Expr]
es [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr] -> [Expr]
sq [Expr]
es
sq :: [Expr] -> [Expr]
sq [Expr]
es = [Expr] -> [Expr]
forall a. Eq a => [a] -> [a]
nub ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Expr
holeAsTypeOf ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ [Expr]
es [Expr] -> [Expr] -> [Expr]
>$$< [Expr]
es
primitiveApplications :: [Expr] -> [[Expr]]
primitiveApplications :: [Expr] -> [[Expr]]
primitiveApplications [Expr]
prims = ([Expr] -> Bool) -> [[Expr]] -> [[Expr]]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> ([Expr] -> Bool) -> [Expr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
([[Expr]] -> [[Expr]]) -> [[Expr]] -> [[Expr]]
forall a b. (a -> b) -> a -> b
$ ([Expr] -> [Expr]) -> [Expr] -> [[Expr]]
forall a. (a -> a) -> a -> [a]
iterate ([Expr] -> [Expr] -> [Expr]
>$$< [Expr] -> [Expr]
primitiveHoles [Expr]
prims) [Expr]
prims
valuesBFS :: Expr -> [Expr]
valuesBFS :: Expr -> [Expr]
valuesBFS = [[Expr]] -> [Expr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Expr]] -> [Expr]) -> (Expr -> [[Expr]]) -> Expr -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [[Expr]]
bfs
where
bfs :: Expr -> [[Expr]]
bfs :: Expr -> [[Expr]]
bfs (Expr
ef :$ Expr
ex) = [] [Expr] -> [[Expr]] -> [[Expr]]
forall a. a -> [a] -> [a]
: [[Expr]] -> [[Expr]] -> [[Expr]]
forall a. Monoid a => [a] -> [a] -> [a]
mzip (Expr -> [[Expr]]
bfs Expr
ef) (Expr -> [[Expr]]
bfs Expr
ex)
bfs Expr
e = [[Expr
e]]
holesBFS :: Expr -> [Expr]
holesBFS :: Expr -> [Expr]
holesBFS = (Expr -> Bool) -> [Expr] -> [Expr]
forall a. (a -> Bool) -> [a] -> [a]
filter Expr -> Bool
isHole ([Expr] -> [Expr]) -> (Expr -> [Expr]) -> Expr -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr]
valuesBFS
fillBFS :: Expr -> Expr -> Expr
fillBFS :: Expr -> Expr -> Expr
fillBFS Expr
e Expr
e' = (Expr, Maybe Int) -> Expr
forall a b. (a, b) -> a
fst (Expr -> (Expr, Maybe Int)
f Expr
e)
where
f :: Expr -> (Expr,Maybe Int)
f :: Expr -> (Expr, Maybe Int)
f (Expr
ef :$ Expr
ex) = case (Maybe Int
mf, Maybe Int
mx) of
(Maybe Int
Nothing, Maybe Int
Nothing) -> (Expr
ef Expr -> Expr -> Expr
:$ Expr
ex, Maybe Int
forall a. Maybe a
Nothing)
(Just Int
lf, Maybe Int
Nothing) -> (Expr
ef' Expr -> Expr -> Expr
:$ Expr
ex, Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
lfInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
(Maybe Int
Nothing, Just Int
lx) -> (Expr
ef Expr -> Expr -> Expr
:$ Expr
ex', Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
lxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
(Just Int
lf, Just Int
lx) | Int
lf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lx -> (Expr
ef' Expr -> Expr -> Expr
:$ Expr
ex, Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
lfInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
| Bool
otherwise -> (Expr
ef Expr -> Expr -> Expr
:$ Expr
ex', Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
lxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
where
(Expr
ef', Maybe Int
mf) = Expr -> (Expr, Maybe Int)
f Expr
ef
(Expr
ex', Maybe Int
mx) = Expr -> (Expr, Maybe Int)
f Expr
ex
f Expr
e | Expr -> Bool
isHole Expr
e Bool -> Bool -> Bool
&& Expr -> TypeRep
typ Expr
e TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
e' = (Expr
e', Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)
| Bool
otherwise = (Expr
e, Maybe Int
forall a. Maybe a
Nothing)
showEq :: Expr -> String
showEq :: Expr -> String
showEq (((Value String
"==" Dynamic
_) :$ Expr
lhs) :$ Expr
rhs) = Expr -> String
showExpr Expr
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
showExpr Expr
rhs
showEq Expr
e = String
"not an Eq: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e
lhs, rhs :: Expr -> Expr
lhs :: Expr -> Expr
lhs (((Value String
"==" Dynamic
_) :$ Expr
e) :$ Expr
_) = Expr
e
rhs :: Expr -> Expr
rhs (((Value String
"==" Dynamic
_) :$ Expr
_) :$ Expr
e) = Expr
e
($$**) :: Expr -> Expr -> Maybe Expr
Expr
e1 $$** :: Expr -> Expr -> Maybe Expr
$$** Expr
e2 = Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Expr
e1 Expr -> Expr -> Expr
:$ Expr
e2
($$|<) :: Expr -> Expr -> Maybe Expr
Expr
e1 $$|< :: Expr -> Expr -> Maybe Expr
$$|< Expr
e2 = if TypeRep -> Bool
isFunTy TypeRep
t1 Bool -> Bool -> Bool
&& TypeRep -> Int
tyArity (TypeRep -> TypeRep
argumentTy TypeRep
t1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep -> Int
tyArity TypeRep
t2
then Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Expr
e1 Expr -> Expr -> Expr
:$ Expr
e2
else Maybe Expr
forall a. Maybe a
Nothing
where
t1 :: TypeRep
t1 = Expr -> TypeRep
ktyp Expr
e1
t2 :: TypeRep
t2 = Expr -> TypeRep
ktyp Expr
e2
ktyp :: Expr -> TypeRep
ktyp :: Expr -> TypeRep
ktyp (Expr
e1 :$ Expr
e2) = TypeRep -> TypeRep
resultTy (Expr -> TypeRep
ktyp Expr
e1)
ktyp Expr
e = Expr -> TypeRep
typ Expr
e
possibleHoles :: [Expr] -> [Expr]
possibleHoles :: [Expr] -> [Expr]
possibleHoles = [Expr] -> [Expr]
nubSort ([Expr] -> [Expr]) -> ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> [Expr]
ph ([Expr] -> [Expr]) -> ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> [Expr]
nubSort ([Expr] -> [Expr]) -> ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> Expr) -> [Expr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Expr
holeAsTypeOf
where
ph :: [Expr] -> [Expr]
ph [Expr]
hs = case [Expr] -> [Expr]
nubSort ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ [Expr]
hs [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr -> Expr
holeAsTypeOf Expr
hfx | Expr
hf <- [Expr]
hs, Expr
hx <- [Expr]
hs, Just Expr
hfx <- [Expr
hf Expr -> Expr -> Maybe Expr
$$ Expr
hx]] of
[Expr]
hs' | [Expr]
hs' [Expr] -> [Expr] -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr]
hs -> [Expr]
hs
| Bool
otherwise -> [Expr] -> [Expr]
ph [Expr]
hs'
nubSort :: [Expr] -> [Expr]
nubSort = [Expr] -> [Expr]
forall a. Eq a => [a] -> [a]
nub ([Expr] -> [Expr]) -> ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> [Expr]
forall a. Ord a => [a] -> [a]
sort
enumerateAppsFor :: Expr -> (Expr -> Bool) -> [[Expr]] -> [[Expr]]
enumerateAppsFor :: Expr -> (Expr -> Bool) -> [[Expr]] -> [[Expr]]
enumerateAppsFor = Expr -> (Expr -> Bool) -> [[Expr]] -> [[Expr]]
enumerateApps3For
enumerateApps :: (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps :: (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps = (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1
enumerateApps1For :: Expr -> (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1For :: Expr -> (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1For Expr
h Expr -> Bool
keep = (Expr -> Bool) -> [[Expr]] -> [[Expr]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT (\Expr
e -> Expr -> TypeRep
typ Expr
e TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
h) ([[Expr]] -> [[Expr]])
-> ([Expr] -> [[Expr]]) -> [Expr] -> [[Expr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1 Expr -> Bool
keep
enumerateApps1 :: (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1 :: (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps1 Expr -> Bool
keep = [[Expr]] -> [[Expr]]
exprT ([[Expr]] -> [[Expr]])
-> ([Expr] -> [[Expr]]) -> [Expr] -> [[Expr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Expr] -> [[Expr]] -> [[Expr]]
forall a. a -> [a] -> [a]
:[])
where
exprT :: [[Expr]] -> [[Expr]]
exprT [[Expr]]
ess = (Expr -> Bool) -> [[Expr]] -> [[Expr]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT Expr -> Bool
keep
([[Expr]] -> [[Expr]]) -> [[Expr]] -> [[Expr]]
forall a b. (a -> b) -> a -> b
$ [[Expr]]
ess [[Expr]] -> [[Expr]] -> [[Expr]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ ([[Expr]] -> [[Expr]]
forall a. [[a]] -> [[a]]
delay ([[Expr]] -> [[Expr]]) -> [[Expr]] -> [[Expr]]
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr -> Maybe Expr) -> [[Expr]] -> [[Expr]] -> [[Expr]]
forall a b c. (a -> b -> Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith Expr -> Expr -> Maybe Expr
($$) [[Expr]]
rss [[Expr]]
rss)
where
rss :: [[Expr]]
rss = [[Expr]] -> [[Expr]]
exprT [[Expr]]
ess
enumerateApps2For :: Expr -> (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps2For :: Expr -> (Expr -> Bool) -> [Expr] -> [[Expr]]
enumerateApps2For Expr
h Expr -> Bool
keep = ([[Expr]] -> [Expr]) -> [[[Expr]]] -> [[Expr]]
forall a b. (a -> b) -> [a] -> [b]
map [[Expr]] -> [Expr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[[Expr]]] -> [[Expr]])
-> ([Expr] -> [[[Expr]]]) -> [Expr] -> [[Expr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Expr] -> Bool) -> [[[Expr]]] -> [[[Expr]]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT (\(Expr
e:[Expr]
_) -> Expr -> TypeRep
typ Expr
e TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
h)
([[[Expr]]] -> [[[Expr]]])
-> ([Expr] -> [[[Expr]]]) -> [Expr] -> [[[Expr]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Expr]]] -> [[[Expr]]]
exprT
([[[Expr]]] -> [[[Expr]]])
-> ([Expr] -> [[[Expr]]]) -> [Expr] -> [[[Expr]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Expr] -> [[Expr]]) -> [[Expr]] -> [[[Expr]]]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> TypeRep) -> [Expr] -> [[Expr]]
forall b a. Eq b => (a -> b) -> [a] -> [[a]]
groupOn Expr -> TypeRep
typ ([Expr] -> [[Expr]]) -> ([Expr] -> [Expr]) -> [Expr] -> [[Expr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> TypeRep) -> [Expr] -> [Expr]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Expr -> TypeRep
typ)
([[Expr]] -> [[[Expr]]])
-> ([Expr] -> [[Expr]]) -> [Expr] -> [[[Expr]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Expr] -> [[Expr]] -> [[Expr]]
forall a. a -> [a] -> [a]
:[])
where
exprT :: [[[Expr]]] -> [[[Expr]]]
exprT :: [[[Expr]]] -> [[[Expr]]]
exprT [[[Expr]]]
ess = [[[Expr]]]
ess [[[Expr]]] -> [[[Expr]]] -> [[[Expr]]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ ([[[Expr]]] -> [[[Expr]]]
forall a. [[a]] -> [[a]]
delay ([[[Expr]]] -> [[[Expr]]]) -> [[[Expr]]] -> [[[Expr]]]
forall a b. (a -> b) -> a -> b
$ ([Expr] -> [Expr] -> Maybe [Expr])
-> [[[Expr]]] -> [[[Expr]]] -> [[[Expr]]]
forall a b c. (a -> b -> Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith [Expr] -> [Expr] -> Maybe [Expr]
($$**) [[[Expr]]]
rss [[[Expr]]]
rss)
where
rss :: [[[Expr]]]
rss = [[[Expr]]] -> [[[Expr]]]
exprT [[[Expr]]]
ess
[Expr]
efs $$** :: [Expr] -> [Expr] -> Maybe [Expr]
$$** [Expr]
exs
| Maybe Expr -> Bool
forall a. Maybe a -> Bool
isNothing ([Expr] -> Expr
forall a. [a] -> a
head [Expr]
efs Expr -> Expr -> Maybe Expr
$$ [Expr] -> Expr
forall a. [a] -> a
head [Expr]
exs) = Maybe [Expr]
forall a. Maybe a
Nothing
| Bool
otherwise = case [Expr
ef Expr -> Expr -> Expr
:$ Expr
ex | Expr
ef <- [Expr]
efs, Expr
ex <- [Expr]
exs, Expr -> Bool
keep (Expr
ef Expr -> Expr -> Expr
:$ Expr
ex)] of
[] -> Maybe [Expr]
forall a. Maybe a
Nothing
[Expr]
es -> [Expr] -> Maybe [Expr]
forall a. a -> Maybe a
Just [Expr]
es
enumerateApps3For :: Expr -> (Expr -> Bool) -> [[Expr]] -> [[Expr]]
enumerateApps3For :: Expr -> (Expr -> Bool) -> [[Expr]] -> [[Expr]]
enumerateApps3For Expr
h Expr -> Bool
keep [[Expr]]
ess = Expr -> [[Expr]]
for Expr
h
where
hs :: [Expr]
hs :: [Expr]
hs = [Expr] -> [Expr]
possibleHoles ([Expr] -> [Expr]) -> ([[Expr]] -> [Expr]) -> [[Expr]] -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Expr]] -> [Expr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Expr]] -> [Expr]) -> [[Expr]] -> [Expr]
forall a b. (a -> b) -> a -> b
$ Int -> [[Expr]] -> [[Expr]]
forall a. Int -> [a] -> [a]
take Int
1 [[Expr]]
ess
for :: Expr -> [[Expr]]
for :: Expr -> [[Expr]]
for Expr
h = (Expr -> Bool) -> [[Expr]] -> [[Expr]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT (\Expr
e -> Expr -> TypeRep
typ Expr
h TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
e) [[Expr]]
ess [[Expr]] -> [[Expr]] -> [[Expr]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ [[Expr]] -> [[Expr]]
forall a. [[a]] -> [[a]]
delay [[Expr]]
apps
where
apps :: [[Expr]]
apps = ([[Expr]] -> [[Expr]] -> [[Expr]])
-> [[Expr]] -> [[[Expr]]] -> [[Expr]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [[Expr]] -> [[Expr]] -> [[Expr]]
forall a. [[a]] -> [[a]] -> [[a]]
(\/) []
[ (Expr -> Bool) -> [[Expr]] -> [[Expr]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT Expr -> Bool
keep ([[Expr]] -> [[Expr]]) -> [[Expr]] -> [[Expr]]
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr -> Expr) -> [[Expr]] -> [[Expr]] -> [[Expr]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith Expr -> Expr -> Expr
(:$) (Expr -> [[Expr]]
for Expr
hf) (Expr -> [[Expr]]
for Expr
hx)
| Expr
hf <- [Expr]
hs
, Expr
hx <- [Expr]
hs
, Just Expr
hfx <- [Expr
hf Expr -> Expr -> Maybe Expr
$$ Expr
hx]
, Expr -> TypeRep
typ Expr
h TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
hfx
]
isDeconstructionE :: [Expr] -> Expr -> Expr -> Bool
isDeconstructionE :: [Expr] -> Expr -> Expr -> Bool
isDeconstructionE [] Expr
_ Expr
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"isDeconstructionE: empty list of test values"
isDeconstructionE [Expr]
es Expr
ez Expr
ed | (Expr -> Bool) -> [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr -> Bool
isIllTyped [Expr
f Expr -> Expr -> Expr
:$ Expr
e | Expr
e <- [Expr]
es, Expr
f <- [Expr
ez,Expr
ed]] = String -> Bool
forall a. HasCallStack => String -> a
error String
"isDeconstructionE: types do not match"
isDeconstructionE [Expr]
es Expr
ez Expr
ed = [Expr] -> (Expr -> Bool) -> (Expr -> Expr) -> Bool
forall a. [a] -> (a -> Bool) -> (a -> a) -> Bool
isDeconstruction [Expr]
es (Bool -> Expr -> Bool
forall a. Typeable a => a -> Expr -> a
eval Bool
False (Expr -> Bool) -> (Expr -> Expr) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr
ez Expr -> Expr -> Expr
:$)) (Expr
ed Expr -> Expr -> Expr
:$)
recursiveToDynamic :: (Expr,Expr) -> Int -> Expr -> Maybe Dynamic
recursiveToDynamic :: (Expr, Expr) -> Int -> Expr -> Maybe Dynamic
recursiveToDynamic (Expr
efxs, Expr
ebody) Int
n = ((Int, Int, Dynamic) -> Dynamic)
-> Maybe (Int, Int, Dynamic) -> Maybe Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
_,Int
_,Dynamic
d) -> Dynamic
d) (Maybe (Int, Int, Dynamic) -> Maybe Dynamic)
-> (Expr -> Maybe (Int, Int, Dynamic)) -> Expr -> Maybe Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Expr -> Int
size Expr
ebody) Int
n
where
(Expr
ef':[Expr]
exs') = Expr -> [Expr]
unfoldApp Expr
efxs
rev :: Typeable a => Int -> Int -> Expr -> Maybe (Int, Int, a)
rev :: Int -> Int -> Expr -> Maybe (Int, Int, a)
rev Int
m Int
n Expr
e = case Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
e of
Maybe (Int, Int, Dynamic)
Nothing -> Maybe (Int, Int, a)
forall a. Maybe a
Nothing
Just (Int
m,Int
n,Dynamic
d) -> case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
d of
Maybe a
Nothing -> Maybe (Int, Int, a)
forall a. Maybe a
Nothing
Just a
x -> (Int, Int, a) -> Maybe (Int, Int, a)
forall a. a -> Maybe a
Just (Int
m, Int
n, a
x)
re :: Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re :: Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Maybe (Int, Int, Dynamic)
forall a. HasCallStack => String -> a
error String
"recursiveToDynamic: recursion limit reached"
re Int
m Int
n Expr
_ | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Maybe (Int, Int, Dynamic)
forall a. HasCallStack => String -> a
error String
"recursiveToDynamic: evaluation limit reached"
re Int
m Int
n (Value String
"if" Dynamic
_ :$ Expr
ec :$ Expr
ex :$ Expr
ey) = case Int -> Int -> Expr -> Maybe (Int, Int, Bool)
forall a. Typeable a => Int -> Int -> Expr -> Maybe (Int, Int, a)
rev Int
m Int
n Expr
ec of
Maybe (Int, Int, Bool)
Nothing -> Maybe (Int, Int, Dynamic)
forall a. Maybe a
Nothing
Just (Int
m,Int
n,Bool
True) -> Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
ex
Just (Int
m,Int
n,Bool
False) -> Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
ey
re Int
m Int
n (Value String
"||" Dynamic
_ :$ Expr
ep :$ Expr
eq) = case Int -> Int -> Expr -> Maybe (Int, Int, Bool)
forall a. Typeable a => Int -> Int -> Expr -> Maybe (Int, Int, a)
rev Int
m Int
n Expr
ep of
Maybe (Int, Int, Bool)
Nothing -> Maybe (Int, Int, Dynamic)
forall a. Maybe a
Nothing
Just (Int
m,Int
n,Bool
True) -> (Int
m,Int
n,) (Dynamic -> (Int, Int, Dynamic))
-> Maybe Dynamic -> Maybe (Int, Int, Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Dynamic
toDynamic (Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val Bool
True)
Just (Int
m,Int
n,Bool
False) -> Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
eq
re Int
m Int
n (Value String
"&&" Dynamic
_ :$ Expr
ep :$ Expr
eq) = case Int -> Int -> Expr -> Maybe (Int, Int, Bool)
forall a. Typeable a => Int -> Int -> Expr -> Maybe (Int, Int, a)
rev Int
m Int
n Expr
ep of
Maybe (Int, Int, Bool)
Nothing -> Maybe (Int, Int, Dynamic)
forall a. Maybe a
Nothing
Just (Int
m,Int
n,Bool
True) -> Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
eq
Just (Int
m,Int
n,Bool
False) -> (Int
m,Int
n,) (Dynamic -> (Int, Int, Dynamic))
-> Maybe Dynamic -> Maybe (Int, Int, Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Dynamic
toDynamic (Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val Bool
False)
re Int
m Int
n Expr
e = case Expr -> [Expr]
unfoldApp Expr
e of
[] -> String -> Maybe (Int, Int, Dynamic)
forall a. HasCallStack => String -> a
error String
"recursiveToDynamic: empty application unfold"
[Expr
e] -> (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
n,) (Dynamic -> (Int, Int, Dynamic))
-> Maybe Dynamic -> Maybe (Int, Int, Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Dynamic
toDynamic Expr
e
(Expr
ef:[Expr]
exs) | Expr
ef Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Expr
ef' -> Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Expr -> Maybe (Int, Int, Dynamic))
-> Expr -> Maybe (Int, Int, Dynamic)
forall a b. (a -> b) -> a -> b
$ Expr
ebody Expr -> [(Expr, Expr)] -> Expr
//- [Expr] -> [Expr] -> [(Expr, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
exs' [Expr]
exs
| Bool
otherwise -> (Maybe (Int, Int, Dynamic) -> Expr -> Maybe (Int, Int, Dynamic))
-> Maybe (Int, Int, Dynamic) -> [Expr] -> Maybe (Int, Int, Dynamic)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe (Int, Int, Dynamic) -> Expr -> Maybe (Int, Int, Dynamic)
($$) (Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
ef) [Expr]
exs
Just (Int
m,Int
n,Dynamic
d1) $$ :: Maybe (Int, Int, Dynamic) -> Expr -> Maybe (Int, Int, Dynamic)
$$ Expr
e2 = case Int -> Int -> Expr -> Maybe (Int, Int, Dynamic)
re Int
m Int
n Expr
e2 of
Maybe (Int, Int, Dynamic)
Nothing -> Maybe (Int, Int, Dynamic)
forall a. Maybe a
Nothing
Just (Int
m', Int
n', Dynamic
d2) -> (Int
m',Int
n',) (Dynamic -> (Int, Int, Dynamic))
-> Maybe Dynamic -> Maybe (Int, Int, Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Dynamic -> Maybe Dynamic
dynApply Dynamic
d1 Dynamic
d2
Maybe (Int, Int, Dynamic)
_ $$ Expr
_ = Maybe (Int, Int, Dynamic)
forall a. Maybe a
Nothing
revaluate :: Typeable a => (Expr,Expr) -> Int -> Expr -> Maybe a
revaluate :: (Expr, Expr) -> Int -> Expr -> Maybe a
revaluate (Expr, Expr)
dfn Int
n Expr
e = (Expr, Expr) -> Int -> Expr -> Maybe Dynamic
recursiveToDynamic (Expr, Expr)
dfn Int
n Expr
e Maybe Dynamic -> (Dynamic -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
reval :: Typeable a => (Expr,Expr) -> Int -> a -> Expr -> a
reval :: (Expr, Expr) -> Int -> a -> Expr -> a
reval (Expr, Expr)
dfn Int
n a
x Expr
e = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x ((Expr, Expr) -> Int -> Expr -> Maybe a
forall a. Typeable a => (Expr, Expr) -> Int -> Expr -> Maybe a
revaluate (Expr, Expr)
dfn Int
n Expr
e)