module Data.Express.Instances
( reifyEq
, reifyOrd
, reifyEqOrd
, reifyName
, mkEq
, mkOrd
, mkOrdLessEqual
, mkName
, mkNameWith
, isEq
, isOrd
, isEqOrd
, isEqT
, isOrdT
, isEqOrdT
, mkEquation
, mkComparisonLE
, mkComparisonLT
, mkComparison
, lookupComparison
, listVarsWith
, lookupName
, lookupNames
, validApps
, findValidApp
, preludeNameInstances
)
where
import Data.Express.Basic
import Data.Express.Name
import Data.Express.Express
import Data.Express.Utils.Typeable
import Data.Express.Utils.List
import Data.Maybe
import Control.Applicative ((<$>))
reifyEq :: (Typeable a, Eq a) => a -> [Expr]
reifyEq :: a -> [Expr]
reifyEq a
a = (a -> a -> Bool) -> [Expr]
forall a. Typeable a => (a -> a -> Bool) -> [Expr]
mkEq (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> a -> a -> a -> Bool
forall a b. (a -> b) -> a -> a -> b
-:> a
a)
reifyOrd :: (Typeable a, Ord a) => a -> [Expr]
reifyOrd :: a -> [Expr]
reifyOrd a
a = (a -> a -> Ordering) -> [Expr]
forall a. Typeable a => (a -> a -> Ordering) -> [Expr]
mkOrd (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering) -> a -> a -> a -> Ordering
forall a b. (a -> b) -> a -> a -> b
-:> a
a)
reifyEqOrd :: (Typeable a, Ord a) => a -> [Expr]
reifyEqOrd :: a -> [Expr]
reifyEqOrd a
a = a -> [Expr]
forall a. (Typeable a, Eq a) => a -> [Expr]
reifyEq a
a [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ a -> [Expr]
forall a. (Typeable a, Ord a) => a -> [Expr]
reifyOrd a
a
reifyName :: (Typeable a, Name a) => a -> [Expr]
reifyName :: a -> [Expr]
reifyName a
a = (a -> String) -> [Expr]
forall a. Typeable a => (a -> String) -> [Expr]
mkName (a -> String
forall a. Name a => a -> String
name (a -> String) -> a -> a -> String
forall a b. (a -> b) -> a -> a -> b
-:> a
a)
mkEq :: Typeable a => (a -> a -> Bool) -> [Expr]
mkEq :: (a -> a -> Bool) -> [Expr]
mkEq a -> a -> Bool
(==) =
[ String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"==" a -> a -> Bool
(==)
, String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"/=" a -> a -> Bool
(/=)
]
where
a
x /= :: a -> a -> Bool
/= a
y = Bool -> Bool
not (a
x a -> a -> Bool
== a
y)
mkOrd :: Typeable a => (a -> a -> Ordering) -> [Expr]
mkOrd :: (a -> a -> Ordering) -> [Expr]
mkOrd a -> a -> Ordering
compare =
[ String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"<=" a -> a -> Bool
(<=)
, String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"<" a -> a -> Bool
(<)
]
where
a
x < :: a -> a -> Bool
< a
y = a
x a -> a -> Ordering
`compare` a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT
a
x <= :: a -> a -> Bool
<= a
y = a
x a -> a -> Ordering
`compare` a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
mkOrdLessEqual :: Typeable a => (a -> a -> Bool) -> [Expr]
mkOrdLessEqual :: (a -> a -> Bool) -> [Expr]
mkOrdLessEqual a -> a -> Bool
(<=) =
[ String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"<=" a -> a -> Bool
(<=)
, String -> (a -> a -> Bool) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"<" a -> a -> Bool
(<)
]
where
a
x < :: a -> a -> Bool
< a
y = Bool -> Bool
not (a
y a -> a -> Bool
<= a
x)
mkName :: Typeable a => (a -> String) -> [Expr]
mkName :: (a -> String) -> [Expr]
mkName a -> String
name = [String -> (a -> String) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"name" a -> String
name]
mkNameWith :: Typeable a => String -> a -> [Expr]
mkNameWith :: String -> a -> [Expr]
mkNameWith String
n a
a = [String -> (a -> String) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"name" (String -> a -> String
forall a b. a -> b -> a
const String
n (a -> String) -> a -> a -> String
forall a b. (a -> b) -> a -> a -> b
-:> a
a)]
lookupComparison :: String -> TypeRep -> [Expr] -> Maybe Expr
lookupComparison :: String -> TypeRep -> [Expr] -> Maybe Expr
lookupComparison String
n' TypeRep
t = (Expr -> Bool) -> [Expr] -> Maybe Expr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\i :: Expr
i@(Value String
n Dynamic
_) -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n' Bool -> Bool -> Bool
&& Expr -> TypeRep
typ Expr
i TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep -> TypeRep
mkComparisonTy TypeRep
t)
isEqT :: [Expr] -> TypeRep -> Bool
isEqT :: [Expr] -> TypeRep -> Bool
isEqT [Expr]
is TypeRep
t = Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Expr -> Bool) -> Maybe Expr -> Bool
forall a b. (a -> b) -> a -> b
$ String -> TypeRep -> [Expr] -> Maybe Expr
lookupComparison String
"==" TypeRep
t [Expr]
is
isOrdT :: [Expr] -> TypeRep -> Bool
isOrdT :: [Expr] -> TypeRep -> Bool
isOrdT [Expr]
is TypeRep
t = Maybe Expr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Expr -> Bool) -> Maybe Expr -> Bool
forall a b. (a -> b) -> a -> b
$ String -> TypeRep -> [Expr] -> Maybe Expr
lookupComparison String
"<=" TypeRep
t [Expr]
is
isEqOrdT :: [Expr] -> TypeRep -> Bool
isEqOrdT :: [Expr] -> TypeRep -> Bool
isEqOrdT [Expr]
is TypeRep
t = [Expr] -> TypeRep -> Bool
isEqT [Expr]
is TypeRep
t Bool -> Bool -> Bool
&& [Expr] -> TypeRep -> Bool
isOrdT [Expr]
is TypeRep
t
isEq :: [Expr] -> Expr -> Bool
isEq :: [Expr] -> Expr -> Bool
isEq [Expr]
is = [Expr] -> TypeRep -> Bool
isEqT [Expr]
is (TypeRep -> Bool) -> (Expr -> TypeRep) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> TypeRep
typ
isOrd :: [Expr] -> Expr -> Bool
isOrd :: [Expr] -> Expr -> Bool
isOrd [Expr]
is = [Expr] -> TypeRep -> Bool
isOrdT [Expr]
is (TypeRep -> Bool) -> (Expr -> TypeRep) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> TypeRep
typ
isEqOrd :: [Expr] -> Expr -> Bool
isEqOrd :: [Expr] -> Expr -> Bool
isEqOrd [Expr]
is Expr
e = [Expr] -> Expr -> Bool
isEq [Expr]
is Expr
e Bool -> Bool -> Bool
&& [Expr] -> Expr -> Bool
isOrd [Expr]
is Expr
e
mkComparison :: String -> [Expr] -> Expr -> Expr -> Expr
mkComparison :: String -> [Expr] -> Expr -> Expr -> Expr
mkComparison String
n' [Expr]
is Expr
e1 Expr
e2 = Expr -> Maybe Expr -> Expr
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val Bool
False) (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ do
Expr
e1e <- [Expr] -> Expr -> Maybe Expr
findValidApp [Expr]
os Expr
e1
Expr
e1e Expr -> Expr -> Maybe Expr
$$ Expr
e2
where
os :: [Expr]
os = [Expr
eq | eq :: Expr
eq@(Value String
n Dynamic
_) <- [Expr]
is, String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n']
mkEquation :: [Expr] -> Expr -> Expr -> Expr
mkEquation :: [Expr] -> Expr -> Expr -> Expr
mkEquation = String -> [Expr] -> Expr -> Expr -> Expr
mkComparison String
"=="
mkComparisonLT :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLT :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLT = String -> [Expr] -> Expr -> Expr -> Expr
mkComparison String
"<"
mkComparisonLE :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLE :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLE = String -> [Expr] -> Expr -> Expr -> Expr
mkComparison String
"<="
lookupName :: [Expr] -> Expr -> String
lookupName :: [Expr] -> Expr -> String
lookupName [Expr]
is Expr
e = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
d (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Expr -> String
forall a. Typeable a => a -> Expr -> a
eval String
"x" (Expr -> String) -> Maybe Expr -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr] -> Expr -> Maybe Expr
findValidApp [Expr]
es Expr
e
where
t :: TypeRep
t = Expr -> TypeRep
typ Expr
e
d :: String
d | TypeRep -> Bool
isFunTy TypeRep
t = String
"f"
| Bool
otherwise = Char
'x' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (TypeRep -> Int
countListTy TypeRep
t) Char
's'
es :: [Expr]
es = [Expr
e | e :: Expr
e@(Value String
"name" Dynamic
_) <- [Expr]
is]
lookupNames :: [Expr] -> Expr -> [String]
lookupNames :: [Expr] -> Expr -> [String]
lookupNames [Expr]
is = String -> [String]
variableNamesFromTemplate (String -> [String]) -> (Expr -> String) -> Expr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> Expr -> String
lookupName [Expr]
is
listVarsWith :: [Expr] -> Expr -> [Expr]
listVarsWith :: [Expr] -> Expr -> [Expr]
listVarsWith [Expr]
is Expr
e = [Expr] -> Expr -> String
lookupName [Expr]
is Expr
e String -> Expr -> [Expr]
`listVarsAsTypeOf` Expr
e
validApps :: [Expr] -> Expr -> [Expr]
validApps :: [Expr] -> Expr -> [Expr]
validApps [Expr]
es Expr
e = (Expr -> Maybe Expr) -> [Expr] -> [Expr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Expr -> Expr -> Maybe Expr
$$ Expr
e) [Expr]
es
findValidApp :: [Expr] -> Expr -> Maybe Expr
findValidApp :: [Expr] -> Expr -> Maybe Expr
findValidApp [Expr]
es = [Expr] -> Maybe Expr
forall a. [a] -> Maybe a
listToMaybe ([Expr] -> Maybe Expr) -> (Expr -> [Expr]) -> Expr -> Maybe Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> Expr -> [Expr]
validApps [Expr]
es
(-:>) :: (a -> b) -> a -> (a -> b)
-:> :: (a -> b) -> a -> a -> b
(-:>) = (a -> b) -> a -> a -> b
forall a b. a -> b -> a
const
infixl 1 -:>
preludeNameInstances :: [Expr]
preludeNameInstances :: [Expr]
preludeNameInstances = [[Expr]] -> [Expr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ () -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (()
forall a. a
u :: ())
, Bool -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Bool
forall a. a
u :: Bool)
, Int -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Int
forall a. a
u :: Int)
, Integer -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Integer
forall a. a
u :: Integer)
, Char -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Char
forall a. a
u :: Char)
, Ordering -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Ordering
forall a. a
u :: Ordering)
, Rational -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Rational
forall a. a
u :: Rational)
, Float -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Float
forall a. a
u :: Float)
, Double -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Double
forall a. a
u :: Double)
, [()] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([()]
forall a. a
u :: [()])
, [Bool] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Bool]
forall a. a
u :: [Bool])
, [Int] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Int]
forall a. a
u :: [Int])
, [Integer] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Integer]
forall a. a
u :: [Integer])
, String -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (String
forall a. a
u :: [Char])
, [Ordering] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Ordering]
forall a. a
u :: [Ordering])
, [Rational] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Rational]
forall a. a
u :: [Rational])
, [Float] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Float]
forall a. a
u :: [Float])
, [Double] -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ([Double]
forall a. a
u :: [Double])
, Maybe () -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe ()
forall a. a
u :: Maybe ())
, Maybe Bool -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Bool
forall a. a
u :: Maybe Bool)
, Maybe Int -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Int
forall a. a
u :: Maybe Int)
, Maybe Integer -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Integer
forall a. a
u :: Maybe Integer)
, Maybe Char -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Char
forall a. a
u :: Maybe Char)
, Maybe Ordering -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Ordering
forall a. a
u :: Maybe Ordering)
, Maybe Rational -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Rational
forall a. a
u :: Maybe Rational)
, Maybe Float -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Float
forall a. a
u :: Maybe Float)
, Maybe Double -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Maybe Double
forall a. a
u :: Maybe Double)
, ((), ()) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (((), ())
forall a. a
u :: ((),()))
, (Bool, Bool) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Bool, Bool)
forall a. a
u :: (Bool,Bool))
, (Int, Int) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Int, Int)
forall a. a
u :: (Int,Int))
, (Integer, Integer) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Integer, Integer)
forall a. a
u :: (Integer,Integer))
, (Char, Char) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Char, Char)
forall a. a
u :: (Char,Char))
, (Ordering, Ordering) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Ordering, Ordering)
forall a. a
u :: (Ordering,Ordering))
, (Rational, Rational) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Rational, Rational)
forall a. a
u :: (Rational,Rational))
, (Float, Float) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Float, Float)
forall a. a
u :: (Float,Float))
, (Double, Double) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName ((Double, Double)
forall a. a
u :: (Double,Double))
, (() -> ()) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (() -> ()
forall a. a
u :: () -> ())
, (Bool -> Bool) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Bool -> Bool
forall a. a
u :: Bool -> Bool)
, (Int -> Int) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Int -> Int
forall a. a
u :: Int -> Int)
, (Integer -> Integer) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Integer -> Integer
forall a. a
u :: Integer -> Integer)
, (Char -> Char) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Char -> Char
forall a. a
u :: Char -> Char)
, (Ordering -> Ordering) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Ordering -> Ordering
forall a. a
u :: Ordering -> Ordering)
, (Rational -> Rational) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Rational -> Rational
forall a. a
u :: Rational -> Rational)
, (Float -> Float) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Float -> Float
forall a. a
u :: Float -> Float)
, (Double -> Double) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Double -> Double
forall a. a
u :: Double -> Double)
, (() -> () -> ()) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (() -> () -> ()
forall a. a
u :: () -> () -> ())
, (Bool -> Bool -> Bool) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Bool -> Bool -> Bool
forall a. a
u :: Bool -> Bool -> Bool)
, (Int -> Int -> Int) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Int -> Int -> Int
forall a. a
u :: Int -> Int -> Int)
, (Integer -> Integer -> Integer) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Integer -> Integer -> Integer
forall a. a
u :: Integer -> Integer -> Integer)
, (Char -> Char -> Char) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Char -> Char -> Char
forall a. a
u :: Char -> Char -> Char)
, (Ordering -> Ordering -> Ordering) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Ordering -> Ordering -> Ordering
forall a. a
u :: Ordering -> Ordering -> Ordering)
, (Rational -> Rational -> Rational) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Rational -> Rational -> Rational
forall a. a
u :: Rational -> Rational -> Rational)
, (Float -> Float -> Float) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Float -> Float -> Float
forall a. a
u :: Float -> Float -> Float)
, (Double -> Double -> Double) -> [Expr]
forall a. (Typeable a, Name a) => a -> [Expr]
reifyName (Double -> Double -> Double
forall a. a
u :: Double -> Double -> Double)
]
where
u :: a
u :: a
u = a
forall a. HasCallStack => a
undefined