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 = mkEq ((==) -:> a)
reifyOrd :: (Typeable a, Ord a) => a -> [Expr]
reifyOrd a = mkOrd (compare -:> a)
reifyEqOrd :: (Typeable a, Ord a) => a -> [Expr]
reifyEqOrd a = reifyEq a ++ reifyOrd a
reifyName :: (Typeable a, Name a) => a -> [Expr]
reifyName a = mkName (name -:> a)
mkEq :: Typeable a => (a -> a -> Bool) -> [Expr]
mkEq (==) =
[ value "==" (==)
, value "/=" (/=)
]
where
x /= y = not (x == y)
mkOrd :: Typeable a => (a -> a -> Ordering) -> [Expr]
mkOrd compare =
[ value "<=" (<=)
, value "<" (<)
]
where
x < y = x `compare` y == LT
x <= y = x `compare` y /= GT
mkOrdLessEqual :: Typeable a => (a -> a -> Bool) -> [Expr]
mkOrdLessEqual (<=) =
[ value "<=" (<=)
, value "<" (<)
]
where
x < y = not (y <= x)
mkName :: Typeable a => (a -> String) -> [Expr]
mkName name = [value "name" name]
mkNameWith :: Typeable a => String -> a -> [Expr]
mkNameWith n a = [value "name" (const n -:> a)]
lookupComparison :: String -> TypeRep -> [Expr] -> Maybe Expr
lookupComparison n' t = find (\i@(Value n _) -> n == n' && typ i == mkComparisonTy t)
isEqT :: [Expr] -> TypeRep -> Bool
isEqT is t = isJust $ lookupComparison "==" t is
isOrdT :: [Expr] -> TypeRep -> Bool
isOrdT is t = isJust $ lookupComparison "<=" t is
isEqOrdT :: [Expr] -> TypeRep -> Bool
isEqOrdT is t = isEqT is t && isOrdT is t
isEq :: [Expr] -> Expr -> Bool
isEq is = isEqT is . typ
isOrd :: [Expr] -> Expr -> Bool
isOrd is = isOrdT is . typ
isEqOrd :: [Expr] -> Expr -> Bool
isEqOrd is e = isEq is e && isOrd is e
mkComparison :: String -> [Expr] -> Expr -> Expr -> Expr
mkComparison n' is e1 e2 = fromMaybe (val False) $ do
e1e <- findValidApp os e1
e1e $$ e2
where
os = [eq | eq@(Value n _) <- is, n == n']
mkEquation :: [Expr] -> Expr -> Expr -> Expr
mkEquation = mkComparison "=="
mkComparisonLT :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLT = mkComparison "<"
mkComparisonLE :: [Expr] -> Expr -> Expr -> Expr
mkComparisonLE = mkComparison "<="
lookupName :: [Expr] -> Expr -> String
lookupName is e = fromMaybe "x" $ eval "x" <$> findValidApp es e
where
es = [e | e@(Value "name" _) <- is]
lookupNames :: [Expr] -> Expr -> [String]
lookupNames is = variableNamesFromTemplate . lookupName is
listVarsWith :: [Expr] -> Expr -> [Expr]
listVarsWith is e = lookupName is e `listVarsAsTypeOf` e
validApps :: [Expr] -> Expr -> [Expr]
validApps es e = mapMaybe ($$ e) es
findValidApp :: [Expr] -> Expr -> Maybe Expr
findValidApp es = listToMaybe . validApps es
(-:>) :: (a -> b) -> a -> (a -> b)
(-:>) = const
infixl 1 -:>
preludeNameInstances :: [Expr]
preludeNameInstances = concat
[ reifyName (u :: ())
, reifyName (u :: Bool)
, reifyName (u :: Int)
, reifyName (u :: Integer)
, reifyName (u :: Char)
, reifyName (u :: Ordering)
, reifyName (u :: Rational)
, reifyName (u :: Float)
, reifyName (u :: Double)
, reifyName (u :: [()])
, reifyName (u :: [Bool])
, reifyName (u :: [Int])
, reifyName (u :: [Integer])
, reifyName (u :: [Char])
, reifyName (u :: [Ordering])
, reifyName (u :: [Rational])
, reifyName (u :: [Float])
, reifyName (u :: [Double])
, reifyName (u :: Maybe ())
, reifyName (u :: Maybe Bool)
, reifyName (u :: Maybe Int)
, reifyName (u :: Maybe Integer)
, reifyName (u :: Maybe Char)
, reifyName (u :: Maybe Ordering)
, reifyName (u :: Maybe Rational)
, reifyName (u :: Maybe Float)
, reifyName (u :: Maybe Double)
, reifyName (u :: ((),()))
, reifyName (u :: (Bool,Bool))
, reifyName (u :: (Int,Int))
, reifyName (u :: (Integer,Integer))
, reifyName (u :: (Char,Char))
, reifyName (u :: (Ordering,Ordering))
, reifyName (u :: (Rational,Rational))
, reifyName (u :: (Float,Float))
, reifyName (u :: (Double,Double))
, reifyName (u :: () -> ())
, reifyName (u :: Bool -> Bool)
, reifyName (u :: Int -> Int)
, reifyName (u :: Integer -> Integer)
, reifyName (u :: Char -> Char)
, reifyName (u :: Ordering -> Ordering)
, reifyName (u :: Rational -> Rational)
, reifyName (u :: Float -> Float)
, reifyName (u :: Double -> Double)
, reifyName (u :: () -> () -> ())
, reifyName (u :: Bool -> Bool -> Bool)
, reifyName (u :: Int -> Int -> Int)
, reifyName (u :: Integer -> Integer -> Integer)
, reifyName (u :: Char -> Char -> Char)
, reifyName (u :: Ordering -> Ordering -> Ordering)
, reifyName (u :: Rational -> Rational -> Rational)
, reifyName (u :: Float -> Float -> Float)
, reifyName (u :: Double -> Double -> Double)
]
where
u :: a
u = undefined