module Conjure.Conjurable
( Conjurable
, canonicalApplication
, canonicalVarApplication
, unifiedArgumentTiers
, tiersFor
, mkExprTiers
)
where
import Test.LeanCheck
import Test.LeanCheck.Utils
import Conjure.Expr hiding (application)
import Test.Speculate.Expr
class Typeable a => Conjurable a where
argumentHoles :: a -> [Expr]
argumentHoles a
_ = []
argumentTiers :: a -> [ [[Expr]] ]
argumentTiers a
_ = []
instance Conjurable ()
instance Conjurable Int
instance Conjurable Integer
instance Conjurable Bool
instance Typeable a => Conjurable [a]
instance (Typeable a, Typeable b) => Conjurable (a,b)
instance Typeable a => Conjurable (Maybe a)
instance (Typeable a, Typeable b) => Conjurable (Either a b)
instance Conjurable Float
instance Conjurable Double
instance Conjurable Ordering
instance (Typeable a, Typeable b, Typeable c) => Conjurable (a,b,c)
instance (Typeable a, Typeable b, Typeable c, Typeable d) => Conjurable (a,b,c,d)
instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Conjurable (a,b,c,d,e)
instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Conjurable (a,b,c,d,e,f)
instance (Listable a, Name a, Show a, Typeable a, Conjurable b) => Conjurable (a -> b) where
argumentHoles :: (a -> b) -> [Expr]
argumentHoles a -> b
f = a -> Expr
forall a. Typeable a => a -> Expr
hole ((a -> b) -> a
forall a b. (a -> b) -> a
arg1 a -> b
f) Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: b -> [Expr]
forall a. Conjurable a => a -> [Expr]
argumentHoles (a -> b
f a
forall a. HasCallStack => a
undefined)
argumentTiers :: (a -> b) -> [[[Expr]]]
argumentTiers a -> b
f = a -> [[Expr]]
forall a. (Listable a, Show a, Typeable a) => a -> [[Expr]]
mkExprTiers ((a -> b) -> a
forall a b. (a -> b) -> a
arg1 a -> b
f) [[Expr]] -> [[[Expr]]] -> [[[Expr]]]
forall a. a -> [a] -> [a]
: b -> [[[Expr]]]
forall a. Conjurable a => a -> [[[Expr]]]
argumentTiers (a -> b
f a
forall a. HasCallStack => a
undefined)
arg1 :: (a -> b) -> a
arg1 :: (a -> b) -> a
arg1 a -> b
_ = a
forall a. HasCallStack => a
undefined
canonicalArgumentVariables :: Conjurable f => f -> [Expr]
canonicalArgumentVariables :: f -> [Expr]
canonicalArgumentVariables = Expr -> [Expr]
unfoldApp
(Expr -> [Expr]) -> (f -> Expr) -> f -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr
mostGeneralCanonicalVariation
(Expr -> Expr) -> (f -> Expr) -> f -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> Expr
foldApp
([Expr] -> Expr) -> (f -> [Expr]) -> f -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [Expr]
forall a. Conjurable a => a -> [Expr]
argumentHoles
canonicalApplication :: Conjurable f => String -> f -> Expr
canonicalApplication :: String -> f -> Expr
canonicalApplication String
nm f
f = [Expr] -> Expr
foldApp (String -> f -> Expr
forall a. Typeable a => String -> a -> Expr
value String
nm f
f Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: f -> [Expr]
forall a. Conjurable a => a -> [Expr]
canonicalArgumentVariables f
f)
canonicalVarApplication :: Conjurable f => String -> f -> Expr
canonicalVarApplication :: String -> f -> Expr
canonicalVarApplication String
nm f
f = [Expr] -> Expr
foldApp (String -> f -> Expr
forall a. Typeable a => String -> a -> Expr
var String
nm f
f Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: f -> [Expr]
forall a. Conjurable a => a -> [Expr]
canonicalArgumentVariables f
f)
unifiedArgumentTiers :: Conjurable f => f -> [[Expr]]
unifiedArgumentTiers :: f -> [[Expr]]
unifiedArgumentTiers = ([[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]]] -> [[Expr]]) -> (f -> [[[Expr]]]) -> f -> [[Expr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [[[Expr]]]
forall a. Conjurable a => a -> [[[Expr]]]
nubArgumentTiers
nubArgumentTiers :: Conjurable f => f -> [[ [Expr] ]]
nubArgumentTiers :: f -> [[[Expr]]]
nubArgumentTiers = ([[Expr]] -> Maybe Expr) -> [[[Expr]]] -> [[[Expr]]]
forall a a. Eq a => (a -> a) -> [a] -> [a]
nubOn [[Expr]] -> Maybe Expr
tierepr ([[[Expr]]] -> [[[Expr]]]) -> (f -> [[[Expr]]]) -> f -> [[[Expr]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [[[Expr]]]
forall a. Conjurable a => a -> [[[Expr]]]
argumentTiers
where
nubOn :: (a -> a) -> [a] -> [a]
nubOn a -> a
f = (a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> (a -> a) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> a
f)
mkExprTiers :: (Listable a, Show a, Typeable a) => a -> [[Expr]]
mkExprTiers :: a -> [[Expr]]
mkExprTiers a
a = (a -> Expr) -> [[a]] -> [[Expr]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val ([[a]]
forall a. Listable a => [[a]]
tiers [[a]] -> [[a]] -> [[a]]
forall a. a -> a -> a
-: [[a
a]])
tiersFor :: Conjurable f => f -> Expr -> [[Expr]]
tiersFor :: f -> Expr -> [[Expr]]
tiersFor f
f Expr
e = [[[Expr]]] -> [[Expr]]
tf (Bool -> [[Expr]]
forall a. (Listable a, Show a, Typeable a) => a -> [[Expr]]
mkExprTiers (Bool
forall a. HasCallStack => a
undefined :: Bool) [[Expr]] -> [[[Expr]]] -> [[[Expr]]]
forall a. a -> [a] -> [a]
: f -> [[[Expr]]]
forall a. Conjurable a => a -> [[[Expr]]]
argumentTiers f
f)
where
tf :: [[[Expr]]] -> [[Expr]]
tf [] = [[Expr
e]]
tf ([[Expr]]
etiers:[[[Expr]]]
etc) = case [[Expr]]
etiers of
((Expr
e':[Expr]
_):[[Expr]]
_) | Expr -> TypeRep
typ Expr
e' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> TypeRep
typ Expr
e -> [[Expr]]
etiers
[[Expr]]
_ -> [[[Expr]]] -> [[Expr]]
tf [[[Expr]]]
etc
tierepr :: [[Expr]] -> Maybe Expr
tierepr :: [[Expr]] -> Maybe Expr
tierepr ((Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr ([]:(Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr ([]:[]:(Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr ([]:[]:[]:(Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr ([]:[]:[]:[]:(Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr ([]:[]:[]:[]:[]:(Expr
e:[Expr]
_):[[Expr]]
_) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
tierepr [[Expr]]
_ = Maybe Expr
forall a. Maybe a
Nothing