deriving-compat-0.3: src/Data/Ord/Deriving/Internal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-|
Module: Data.Ord.Deriving.Internal
Copyright: (C) 2015-2016 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances.
-}
module Data.Ord.Deriving.Internal (
-- * 'Ord'
deriveOrd
, makeCompare
, makeLE
, makeLT
, makeGT
, makeGE
, makeMax
, makeMin
-- * 'Ord1'
, deriveOrd1
#if defined(NEW_FUNCTOR_CLASSES)
, makeLiftCompare
#endif
, makeCompare1
#if defined(NEW_FUNCTOR_CLASSES)
-- * 'Ord2'
, deriveOrd2
, makeLiftCompare2
, makeCompare2
#endif
) where
import Data.Deriving.Internal
import Data.List (partition)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
-- | Generates an 'Ord' instance declaration for the given data type or data
-- family instance.
deriveOrd :: Name -> Q [Dec]
deriveOrd = deriveOrdClass Ord
-- | Generates a lambda expression which behaves like 'compare' (without
-- requiring an 'Ord' instance).
makeCompare :: Name -> Q Exp
makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen")
-- | Generates a lambda expression which behaves like '(<)' (without
-- requiring an 'Ord' instance).
makeLT :: Name -> Q Exp
makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName) []
, match wildP (normalB $ conE falseDataName) []
]
-- | Generates a lambda expression which behaves like '(<=)' (without
-- requiring an 'Ord' instance).
makeLE :: Name -> Q Exp
makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) []
, match wildP (normalB $ conE trueDataName) []
]
-- | Generates a lambda expression which behaves like '(>)' (without
-- requiring an 'Ord' instance).
makeGT :: Name -> Q Exp
makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName) []
, match wildP (normalB $ conE falseDataName) []
]
-- | Generates a lambda expression which behaves like '(>=)' (without
-- requiring an 'Ord' instance).
makeGE :: Name -> Q Exp
makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) []
, match wildP (normalB $ conE trueDataName) []
]
-- | Generates a lambda expression which behaves like 'max' (without
-- requiring an 'Ord' instance).
makeMax :: Name -> Q Exp
makeMax = makeMinMax flip
-- | Generates a lambda expression which behaves like 'min' (without
-- requiring an 'Ord' instance).
makeMin :: Name -> Q Exp
makeMin = makeMinMax id
makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp)
-> Name -> Q Exp
makeMinMax f name = do
x <- newName "x"
y <- newName "y"
let xExpr = varE x
yExpr = varE y
lamE [varP x, varP y] $
f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr
-- | Generates an 'Ord1' instance declaration for the given data type or data
-- family instance.
deriveOrd1 :: Name -> Q [Dec]
deriveOrd1 = deriveOrdClass Ord1
#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a lambda expression which behaves like 'liftCompare' (without
-- requiring an 'Ord1' instance).
--
-- This function is not available with @transformers-0.4@.
makeLiftCompare :: Name -> Q Exp
makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen")
-- | Generates a lambda expression which behaves like 'compare1' (without
-- requiring an 'Ord1' instance).
makeCompare1 :: Name -> Q Exp
makeCompare1 name = makeLiftCompare name `appE` varE compareValName
#else
-- | Generates a lambda expression which behaves like 'compare1' (without
-- requiring an 'Ord1' instance).
makeCompare1 :: Name -> Q Exp
makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen")
#endif
#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates an 'Ord2' instance declaration for the given data type or data
-- family instance.
--
-- This function is not available with @transformers-0.4@.
deriveOrd2 :: Name -> Q [Dec]
deriveOrd2 = deriveOrdClass Ord2
-- | Generates a lambda expression which behaves like 'liftCompare2' (without
-- requiring an 'Ord2' instance).
--
-- This function is not available with @transformers-0.4@.
makeLiftCompare2 :: Name -> Q Exp
makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen")
-- | Generates a lambda expression which behaves like 'compare2' (without
-- requiring an 'Ord2' instance).
--
-- This function is not available with @transformers-0.4@.
makeCompare2 :: Name -> Q Exp
makeCompare2 name = makeLiftCompare name
`appE` varE compareValName
`appE` varE compareValName
#endif
-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------
-- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass
-- argument's value).
deriveOrdClass :: OrdClass -> Name -> Q [Dec]
deriveOrdClass oClass name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
(instanceCxt, instanceType)
<- buildTypeInstance oClass name' ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(ordFunDecs oClass cons)
-- | Generates a declaration defining the primary function(s) corresponding to a
-- particular class (compare for Ord, liftCompare for Ord1, and
-- liftCompare2 for Ord2).
ordFunDecs :: OrdClass -> [Con] -> [Q Dec]
ordFunDecs oClass cons =
map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons
where
makeFunD :: OrdFun -> Q Dec
makeFunD oFun =
funD (ordFunName oFun $ arity oClass)
[ clause []
(normalB $ makeOrdFunForCons oFun cons)
[]
]
-- | Generates a lambda expression which behaves like the OrdFun value. This
-- function uses heuristics to determine whether to implement the OrdFun from
-- scratch or define it in terms of compare.
makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp
makeOrdFun oFun matches name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys = do
let oClass = ordFunToClass oFun
others = otherFuns oClass cons
-- We force buildTypeInstance here since it performs some checks for whether
-- or not the provided datatype can actually have compare/liftCompare/etc.
-- implemented for it, and produces errors if it can't.
buildTypeInstance oClass name' ctxt tvbs mbTys `seq`
if oFun `elem` compareFuns || oFun `elem` others
then makeOrdFunForCons oFun cons
else do
x <- newName "x"
y <- newName "y"
lamE [varP x, varP y] $
caseE (makeOrdFunForCons (ordClassToCompare oClass) cons
`appE` varE x `appE` varE y)
matches
compareFuns :: [OrdFun]
compareFuns = [ OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
, Ord1LiftCompare
, Ord2LiftCompare2
#else
, Ord1Compare1
#endif
]
-- | Generates a lambda expression for the given constructors.
-- All constructors must be from the same type.
makeOrdFunForCons :: OrdFun -> [Con] -> Q Exp
makeOrdFunForCons _ [] = noConstructorsError
makeOrdFunForCons oFun cons = do
let oClass = ordFunToClass oFun
v1 <- newName "v1"
v2 <- newName "v2"
v1Hash <- newName "v1#"
v2Hash <- newName "v2#"
ords <- newNameList "ord" $ arity oClass
let nullaryCons, nonNullaryCons :: [Con]
(nullaryCons, nonNullaryCons) = partition isNullaryCon cons
singleConType :: Bool
singleConType = isSingleton cons
firstConName, lastConName :: Name
firstConName = constructorName $ head cons
lastConName = constructorName $ last cons
-- I think these should always be the case...
firstTag, lastTag :: Int
firstTag = 0
lastTag = length cons - 1
ordMatches :: Int -> Con -> Q Match
ordMatches = makeOrdFunForCon oFun v2 v2Hash ords singleConType
firstTag firstConName lastTag lastConName
ordFunRhs :: Q Exp
ordFunRhs
| length nullaryCons <= 2
= caseE (varE v1) $ zipWith ordMatches [0..] cons
| null nonNullaryCons
= mkTagCmp
| otherwise
= caseE (varE v1) $ zipWith ordMatches [0..] nonNullaryCons
++ [match wildP (normalB mkTagCmp) []]
mkTagCmp :: Q Exp
mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $
unliftedOrdFun intHashTypeName oFun v1Hash v2Hash
lamE (map varP $
#if defined(NEW_FUNCTOR_CLASSES)
ords ++
#endif
[v1, v2])
. appsE
$ [ varE $ compareConstName oFun
, ordFunRhs
]
#if defined(NEW_FUNCTOR_CLASSES)
++ map varE ords
#endif
++ [varE v1, varE v2]
makeOrdFunForCon :: OrdFun
-> Name
-> Name
-> [Name]
-> Bool
-> Int -> Name
-> Int -> Name
-> Int -> Con
-> Q Match
makeOrdFunForCon oFun v2 v2Hash ords singleConType
firstTag firstConName lastTag lastConName tag con = do
let conName = constructorName con
(ts, tvMap) <- reifyConTys1 (ordFunToClass oFun) ords conName
let tsLen = length ts
as <- newNameList "a" tsLen
bs <- newNameList "b" tsLen
let innerRhs :: Q Exp
innerRhs
| singleConType
= caseE (varE v2) [innerEqAlt]
| tag == firstTag
= caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []]
| tag == lastTag
= caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []]
| tag == firstTag + 1
= caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) []
, innerEqAlt
, match wildP (normalB $ ltResult oFun) []
]
| tag == lastTag - 1
= caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) []
, innerEqAlt
, match wildP (normalB $ gtResult oFun) []
]
| tag > lastTag `div` 2
= untagExpr [(v2, v2Hash)] $
condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit)
(gtResult oFun) $
caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []]
| otherwise
= untagExpr [(v2, v2Hash)] $
condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit)
(ltResult oFun) $
caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []]
innerEqAlt :: Q Match
innerEqAlt = match (conP conName $ map varP bs)
(normalB $ makeOrdFunForFields oFun tvMap conName ts as bs)
[]
tagLit :: Q Exp
tagLit = litE . integerL $ fromIntegral tag
match (conP conName $ map varP as)
(normalB innerRhs)
[]
makeOrdFunForFields :: OrdFun
-> TyVarMap1
-> Name
-> [Type]
-> [Name]
-> [Name]
-> Q Exp
makeOrdFunForFields oFun tvMap conName = go
where
go :: [Type] -> [Name] -> [Name] -> Q Exp
go [] _ _ = eqResult oFun
go [ty] [a] [b]
| isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b
| otherwise = makeOrdFunForType oFun tvMap conName ty
`appE` varE a `appE` varE b
go (ty:tys) (a:as) (b:bs) =
mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun)
go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields"
mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp
mkCompare ty a b lt eq gt
| isSupportedUnliftedType ty =
let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty
in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt
| otherwise
= caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun)
tvMap conName ty `appE` aExpr `appE` bExpr)
[ match (conP ltDataName []) (normalB lt) []
, match (conP eqDataName []) (normalB eq) []
, match (conP gtDataName []) (normalB gt) []
]
where
aExpr, bExpr :: Q Exp
aExpr = varE a
bExpr = varE b
makeOrdFunForType :: OrdFun
-> TyVarMap1
-> Name
-> Type
-> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType oFun tvMap _ (VarT tyName) =
varE $ case Map.lookup tyName tvMap of
Just (OneName ord) -> ord
Nothing -> ordFunName oFun 0
#else
makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0
#endif
makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty
makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty
#if defined(NEW_FUNCTOR_CLASSES)
makeOrdFunForType oFun tvMap conName ty = do
let oClass :: OrdClass
oClass = ordFunToClass oFun
tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (arity oClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
tyVarNames :: [Name]
tyVarNames = Map.keys tvMap
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs
|| itf && any (`mentionsName` tyVarNames) tyArgs
then outOfPlaceTyVarError oClass conName
else appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs]
++ map (makeOrdFunForType oFun tvMap conName) rhsArgs
#else
makeOrdFunForType oFun tvMap conName ty = do
let varNames = Map.keys tvMap
oClass = ordFunToClass oFun
a' <- newName "a'"
b' <- newName "b'"
case varNames of
[] -> varE $ ordFunName oFun 0
varName:_ ->
if mentionsName ty varNames
then lamE (map varP [a',b']) $ varE (ordFunName oFun 1)
`appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a')
`appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b')
else varE $ ordFunName oFun 0
#endif
-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------
-- | A representation of which @Ord@ variant is being derived.
data OrdClass = Ord
| Ord1
#if defined(NEW_FUNCTOR_CLASSES)
| Ord2
#endif
deriving (Bounded, Enum)
instance ClassRep OrdClass where
arity = fromEnum
allowExQuant _ = True
fullClassName Ord = ordTypeName
fullClassName Ord1 = ord1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName Ord2 = ord2TypeName
#endif
classConstraint oClass i
| oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass)
| otherwise = Nothing
where
oMin, oMax :: Int
oMin = fromEnum (minBound :: OrdClass)
oMax = fromEnum oClass
compareConstName :: OrdFun -> Name
compareConstName OrdCompare = compareConstValName
compareConstName OrdLT = ltConstValName
compareConstName OrdLE = ltConstValName
compareConstName OrdGT = ltConstValName
compareConstName OrdGE = ltConstValName
#if defined(NEW_FUNCTOR_CLASSES)
compareConstName Ord1LiftCompare = liftCompareConstValName
compareConstName Ord2LiftCompare2 = liftCompare2ConstValName
#else
compareConstName Ord1Compare1 = compare1ConstValName
#endif
ordClassToCompare :: OrdClass -> OrdFun
ordClassToCompare Ord = OrdCompare
#if defined(NEW_FUNCTOR_CLASSES)
ordClassToCompare Ord1 = Ord1LiftCompare
ordClassToCompare Ord2 = Ord2LiftCompare2
#else
ordClassToCompare Ord1 = Ord1Compare1
#endif
data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
#if defined(NEW_FUNCTOR_CLASSES)
| Ord1LiftCompare | Ord2LiftCompare2
#else
| Ord1Compare1
#endif
deriving Eq
ordFunName :: OrdFun -> Int -> Name
ordFunName OrdCompare 0 = compareValName
ordFunName OrdLT 0 = ltValName
ordFunName OrdLE 0 = leValName
ordFunName OrdGE 0 = geValName
ordFunName OrdGT 0 = gtValName
#if defined(NEW_FUNCTOR_CLASSES)
ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0
ordFunName Ord1LiftCompare 1 = liftCompareValName
ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0
ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1
ordFunName Ord2LiftCompare2 2 = liftCompare2ValName
#else
ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0
ordFunName Ord1Compare1 1 = compare1ValName
#endif
ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName"
ordFunToClass :: OrdFun -> OrdClass
ordFunToClass OrdCompare = Ord
ordFunToClass OrdLT = Ord
ordFunToClass OrdLE = Ord
ordFunToClass OrdGE = Ord
ordFunToClass OrdGT = Ord
#if defined(NEW_FUNCTOR_CLASSES)
ordFunToClass Ord1LiftCompare = Ord1
ordFunToClass Ord2LiftCompare2 = Ord2
#else
ordFunToClass Ord1Compare1 = Ord1
#endif
eqResult :: OrdFun -> Q Exp
eqResult OrdCompare = eqTagExpr
eqResult OrdLT = falseExpr
eqResult OrdLE = trueExpr
eqResult OrdGE = trueExpr
eqResult OrdGT = falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
eqResult Ord1LiftCompare = eqTagExpr
eqResult Ord2LiftCompare2 = eqTagExpr
#else
eqResult Ord1Compare1 = eqTagExpr
#endif
gtResult :: OrdFun -> Q Exp
gtResult OrdCompare = gtTagExpr
gtResult OrdLT = falseExpr
gtResult OrdLE = falseExpr
gtResult OrdGE = trueExpr
gtResult OrdGT = trueExpr
#if defined(NEW_FUNCTOR_CLASSES)
gtResult Ord1LiftCompare = gtTagExpr
gtResult Ord2LiftCompare2 = gtTagExpr
#else
gtResult Ord1Compare1 = gtTagExpr
#endif
ltResult :: OrdFun -> Q Exp
ltResult OrdCompare = ltTagExpr
ltResult OrdLT = trueExpr
ltResult OrdLE = trueExpr
ltResult OrdGE = falseExpr
ltResult OrdGT = falseExpr
#if defined(NEW_FUNCTOR_CLASSES)
ltResult Ord1LiftCompare = ltTagExpr
ltResult Ord2LiftCompare2 = ltTagExpr
#else
ltResult Ord1Compare1 = ltTagExpr
#endif
-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------
ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp
ltTagExpr = conE ltDataName
eqTagExpr = conE eqDataName
gtTagExpr = conE gtDataName
falseExpr = conE falseDataName
trueExpr = conE trueDataName
-- Besides compare, that is
otherFuns :: OrdClass -> [Con] -> [OrdFun]
otherFuns oClass cons = case oClass of
Ord1 -> []
#if defined(NEW_FUNCTOR_CLASSES)
Ord2 -> []
#endif
Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons
-> [OrdLT, OrdLE, OrdGE, OrdGT]
| otherwise
-> []
where
firstTag, lastTag :: Int
firstTag = 0
lastTag = length cons - 1
nonNullaryCons :: [Con]
nonNullaryCons = filterOut isNullaryCon cons
unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp
unliftedOrdFun tyName oFun a b = case oFun of
OrdCompare -> unliftedCompareExpr
OrdLT -> wrap ltFun
OrdLE -> wrap leFun
OrdGE -> wrap geFun
OrdGT -> wrap gtFun
#if defined(NEW_FUNCTOR_CLASSES)
Ord1LiftCompare -> unliftedCompareExpr
Ord2LiftCompare2 -> unliftedCompareExpr
#else
Ord1Compare1 -> unliftedCompareExpr
#endif
where
unliftedCompareExpr :: Q Exp
unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr
ltTagExpr eqTagExpr gtTagExpr
ltFun, leFun, eqFun, geFun, gtFun :: Name
(ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName
wrap :: Name -> Q Exp
wrap primFun = primOpAppExpr aExpr primFun bExpr
aExpr, bExpr :: Q Exp
aExpr = varE a
bExpr = varE b
unliftedCompare :: Name -> Name
-> Q Exp -> Q Exp -- What to compare
-> Q Exp -> Q Exp -> Q Exp -- Three results
-> Q Exp
unliftedCompare ltFun eqFun aExpr bExpr lt eq gt =
condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $
condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt
where
ascribeBool :: Q Exp -> Q Exp
ascribeBool e = sigE e $ conT boolTypeName
primOrdFuns :: Name -> (Name, Name, Name, Name, Name)
primOrdFuns tyName = case lookup tyName primOrdFunTbl of
Just names -> names
Nothing -> error $ nameBase tyName ++ " is not supported."
primOrdFunTbl :: [(Name, (Name, Name, Name, Name, Name))]
primOrdFunTbl =
[ (addrHashTypeName, ( ltAddrHashValName
, leAddrHashValName
, eqAddrHashValName
, geAddrHashValName
, gtAddrHashValName
))
, (charHashTypeName, ( ltCharHashValName
, leCharHashValName
, eqCharHashValName
, geCharHashValName
, gtCharHashValName
))
, (doubleHashTypeName, ( ltDoubleHashValName
, leDoubleHashValName
, eqDoubleHashValName
, geDoubleHashValName
, gtDoubleHashValName
))
, (floatHashTypeName, ( ltFloatHashValName
, leFloatHashValName
, eqFloatHashValName
, geFloatHashValName
, gtFloatHashValName
))
, (intHashTypeName, ( ltIntHashValName
, leIntHashValName
, eqIntHashValName
, geIntHashValName
, gtIntHashValName
))
, (wordHashTypeName, ( ltWordHashValName
, leWordHashValName
, eqWordHashValName
, geWordHashValName
, gtWordHashValName
))
]
isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType (ConT tyName) = isJust $ lookup tyName primOrdFunTbl
isSupportedUnliftedType _ = False
isSingleton :: [a] -> Bool
isSingleton [_] = True
isSingleton _ = False
-- | Like 'filter', only it reverses the sense of the test
filterOut :: (a -> Bool) -> [a] -> [a]
filterOut _ [] = []
filterOut p (x:xs) | p x = filterOut p xs
| otherwise = x : filterOut p xs