-- |
-- Module      : Conjure.Conjurable
-- Copyright   : (c) 2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of 'Conjure'.
--
-- This defines the 'Conjurable' typeclass
-- and utilities involving it.
--
-- You are probably better off importing "Conjure".
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)
  -- NOTE: this is O(n*n),
  -- not much of a problem the number of arguments will hardly pass 6.

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]] -- no tiers found, keep variable
  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

-- | tries to extract a representative from the first 6 tiers
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