{-# LANGUAGE CPP #-}
module Conjure.Expr
( module Data.Express
, module Data.Express.Fixtures
, funToVar
, recursexpr
, apparentlyTerminates
, mayNotEvaluateArgument
, applicationOld
, compareSimplicity
, ifFor
, module Conjure.Utils
)
where
import Conjure.Utils
import Data.Express
import Data.Express.Fixtures hiding ((-==-))
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)