{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}

{-|
Module:      Data.Ord.Deriving.Internal
Copyright:   (C) 2015-2017 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.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
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           Language.Haskell.TH.Datatype
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 = do
  info <- reifyDatatype name
  case info of
    DatatypeInfo { datatypeContext   = ctxt
                 , datatypeName      = parentName
                 , datatypeInstTypes = instTypes
                 , datatypeVariant   = variant
                 , datatypeCons      = cons
                 } -> do
      (instanceCxt, instanceType)
          <- buildTypeInstance oClass parentName ctxt instTypes variant
      (:[]) `fmap` instanceD (return instanceCxt)
                             (return instanceType)
                             (ordFunDecs oClass instTypes 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 -> [Type] -> [ConstructorInfo] -> [Q Dec]
ordFunDecs oClass instTypes cons =
    map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons
  where
    makeFunD :: OrdFun -> Q Dec
    makeFunD oFun =
      funD (ordFunName oFun $ arity oClass)
           [ clause []
                    (normalB $ dispatchFun oFun)
                    []
           ]

    negateExpr :: Q Exp -> Q Exp
    negateExpr = appE (varE notValName)

    dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp
    dispatchLT f = do
        x <- newName "x"
        y <- newName "y"
        lamE [varP x, varP y] $ f (varE ltValName) (varE x) (varE y)

    dispatchFun :: OrdFun -> Q Exp
    dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT
                                     -- OrdLT is included to mirror the fix to
                                     -- GHC Trac #10858.
#if defined(NEW_FUNCTOR_CLASSES)
                                   , Ord1LiftCompare, Ord2LiftCompare2
#else
                                   , Ord1Compare1
#endif
                                   ]
                      = makeOrdFunForCons oFun instTypes cons
    dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x
    dispatchFun OrdGT = dispatchLT $ \lt x y ->              lt `appE` y `appE` x
    dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y
    dispatchFun _     = fail "ordFunDecs"

-- | 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 = do
  info <- reifyDatatype name
  case info of
    DatatypeInfo { datatypeContext   = ctxt
                 , datatypeName      = parentName
                 , datatypeInstTypes = instTypes
                 , datatypeVariant   = variant
                 , datatypeCons      = cons
                 } -> 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 parentName ctxt instTypes variant >>
        if oFun `elem` compareFuns || oFun `elem` others
           then makeOrdFunForCons oFun instTypes cons
           else do
             x <- newName "x"
             y <- newName "y"
             lamE [varP x, varP y] $
                  caseE (makeOrdFunForCons (ordClassToCompare oClass) instTypes cons
                             `appE` varE x `appE` varE y)
                        matches
  where
    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 -> [Type] -> [ConstructorInfo] -> Q Exp
makeOrdFunForCons oFun instTypes cons = do
    let oClass = ordFunToClass oFun
    v1     <- newName "v1"
    v2     <- newName "v2"
    v1Hash <- newName "v1#"
    v2Hash <- newName "v2#"
    ords   <- newNameList "ord" $ arity oClass

    let lastTyVars :: [Name]
        lastTyVars = map varTToName $ drop (length instTypes - fromEnum oClass) instTypes

        tvMap :: TyVarMap1
        tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars ords

        nullaryCons, nonNullaryCons :: [ConstructorInfo]
        (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 -> ConstructorInfo -> Q Match
        ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType
                                      firstTag firstConName lastTag lastConName

        ordFunRhs :: Q Exp
        ordFunRhs
          | null cons
          = conE eqDataName
          | 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
                 -> TyVarMap1
                 -> Bool
                 -> Int -> Name
                 -> Int -> Name
                 -> Int -> ConstructorInfo
                 -> Q Match
makeOrdFunForCon oFun v2 v2Hash tvMap singleConType
                 firstTag firstConName lastTag lastConName tag
  (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do
    ts' <- mapM resolveTypeSynonyms ts
    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 . intPrimL $ 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 if any (`mentionsName` tyVarNames) rhsArgs
               then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs]
                            ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs
               else varE $ ordFunName oFun 0
#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 -> [ConstructorInfo] -> [OrdFun]
otherFuns _ [] = [] -- We only need compare for empty data types.
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 :: [ConstructorInfo]
    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 Map.lookup tyName primOrdFunTbl of
    Just names -> names
    Nothing    -> error $ nameBase tyName ++ " is not supported."

isSupportedUnliftedType :: Type -> Bool
isSupportedUnliftedType (ConT tyName) = Map.member 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