{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-|
Module:      Text.Read.Deriving
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances.
-}
module Text.Read.Deriving.Internal (
      -- * 'Read'
      deriveRead
    , deriveReadOptions
    , makeReadsPrec
--     , makeReadsPrecOptions
--     , makeReadList
--     , makeReadListOptions
    , makeReadPrec
--     , makeReadPrecOptions
--     , makeReadListPrec
--     , makeReadListPrecOptions
      -- * 'Read1'
    , deriveRead1
    , deriveRead1Options
#if defined(NEW_FUNCTOR_CLASSES)
    , makeLiftReadsPrec
--     , makeLiftReadsPrecOptions
--     , makeLiftReadList
--     , makeLiftReadListOptions
# if __GLASGOW_HASKELL__ >= 801
    , makeLiftReadPrec
--     , makeLiftReadPrecOptions
--     , makeLiftReadListPrec
--     , makeLiftReadListPrecOptions
    , makeReadPrec1
--     , makeReadPrec1Options
# endif
#endif
    , makeReadsPrec1
--     , makeReadsPrec1Options
#if defined(NEW_FUNCTOR_CLASSES)
      -- * 'Read2'
    , deriveRead2
    , deriveRead2Options
    , makeLiftReadsPrec2
--     , makeLiftReadsPrec2Options
--     , makeLiftReadList2
--     , makeLiftReadList2Options
# if __GLASGOW_HASKELL__ >= 801
    , makeLiftReadPrec2
--     , makeLiftReadPrec2Options
--     , makeLiftReadListPrec2
--     , makeLiftReadListPrec2Options
    , makeReadPrec2
--     , makeReadPrec2Options
# endif
    , makeReadsPrec2
--     , makeReadsPrec2Options
#endif
      -- * 'ReadOptions'
    , ReadOptions(..)
    , defaultReadOptions
    ) where

#if MIN_VERSION_template_haskell(2,11,0)
import           Control.Monad ((<=<))
import           Data.Maybe (fromMaybe, isJust)
#endif

import           Data.Deriving.Internal
import           Data.List (intersperse, partition)
import qualified Data.Map as Map

import           GHC.Show (appPrec, appPrec1)

import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Syntax

-- | Options that further configure how the functions in "Text.Read.Deriving"
-- should behave.
newtype ReadOptions = ReadOptions
  { useReadPrec :: Bool
    -- ^ If 'True':
    --
    -- * Derived 'Read' instances will implement 'readPrec', not 'readsPrec', and
    --   will provide a default implementation of 'readListPrec' in terms of
    --   'readPrec'.
    --
    -- * If built against @base-4.10@ or later, derived 'Read1'/'Read2'
    --   instances will implement 'liftReadPrec'/'liftReadPrec2', not
    --   'liftReadsPrec'/'liftReadsPrec2', and will provide default implementations
    --   of 'liftReadListPrec'/'liftReadListPrec2' in terms of
    --   'liftReadPrec'/'liftReadPrec2'. If built against an earlier version of
    --   @base@, derived 'Read1'/'Read2' instances are not affected, so they will
    --   act as if this flag were 'False'.
    --
    -- If 'False':
    --
    -- * Derived 'Read' instances will implement 'readsPrec'.
    --
    -- * Derived 'Read1' instances will implement 'readsPrec1' (if built against
    --   @transformers-0.4@) or 'liftReadsPrec' (otherwise). If not built against
    --   @transformers-0.4@, derived 'Read2' instances will implement
    --   'liftReadsPrec2'.
    --
    -- It's generally a good idea to enable this option, since 'readPrec' and
    -- friends are more efficient than 'readsPrec' and friends, since the former
    -- use the efficient 'ReadPrec' parser datatype while the latter use the
    -- slower, list-based 'ReadS' type.
  } deriving (Eq, Ord, Read, Show)

-- | 'ReadOptions' that favor 'readPrec' over 'readsPrec'.
defaultReadOptions :: ReadOptions
defaultReadOptions = ReadOptions { useReadPrec = True }

-- | Generates a 'Read' instance declaration for the given data type or data
-- family instance.
deriveRead :: Name -> Q [Dec]
deriveRead = deriveReadOptions defaultReadOptions

-- | Like 'deriveRead', but takes a 'ReadOptions' argument.
deriveReadOptions :: ReadOptions -> Name -> Q [Dec]
deriveReadOptions = deriveReadClass Read

-- | Generates a lambda expression which behaves like 'readsPrec' (without
-- requiring a 'Read' instance).
makeReadsPrec :: Name -> Q Exp
makeReadsPrec = makeReadPrecClass Read False

-- -- | Like 'readsPrec', but takes a 'ReadOptions' argument.
-- makeReadsPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeReadsPrecOptions _ = makeReadPrecClass Read False
--
-- -- | Generates a lambda expression which behaves like 'readList' (without
-- -- requiring a 'Read' instance).
-- makeReadList :: Name -> Q Exp
-- makeReadList = makeReadListOptions defaultReadOptions
--
-- -- | Like 'readList', but takes a 'ReadOptions' argument.
-- makeReadListOptions :: ReadOptions -> Name -> Q Exp
-- makeReadListOptions opts name =
--     if shouldDefineReadPrec Read opts
--        then varE readPrec_to_SValName
--             `appE` makeReadListPrecOptions opts name
--             `appE` integerE 0
--        else varE readPrec_to_SValName
--             `appE` (varE listValName `appE` makeReadPrecOptions opts name)
--             `appE` integerE 0

-- | Generates a lambda expression which behaves like 'readPrec' (without
-- requiring a 'Read' instance).
makeReadPrec :: Name -> Q Exp
makeReadPrec = makeReadPrecClass Read True

-- -- | Like 'readPrec', but takes a 'ReadOptions' argument.
-- makeReadPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeReadPrecOptions _ = makeReadPrecClass Read True
--
-- -- | Generates a lambda expression which behaves like 'readListPrec' (without
-- -- requiring a 'Read' instance).
-- makeReadListPrec :: Name -> Q Exp
-- makeReadListPrec = makeReadListPrecOptions defaultReadOptions
--
-- -- | Like 'readListPrec', but takes a 'ReadOptions' argument.
-- makeReadListPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeReadListPrecOptions opts name =
--     if shouldDefineReadPrec Read opts
--        then varE listValName `appE` makeReadPrecOptions opts name
--        else varE readS_to_PrecValName
--             `appE` (varE constValName `appE` makeReadListOptions opts name)

-- | Generates a 'Read1' instance declaration for the given data type or data
-- family instance.
deriveRead1 :: Name -> Q [Dec]
deriveRead1 = deriveRead1Options defaultReadOptions

-- | Like 'deriveRead1', but takes a 'ReadOptions' argument.
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options = deriveReadClass Read1

-- -- | Generates a lambda expression which behaves like 'readsPrec1' (without
-- -- requiring a 'Read1' instance).
-- makeReadsPrec1 :: Name -> Q Exp
-- makeReadsPrec1 = makeReadsPrec1Options defaultReadOptions

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a lambda expression which behaves like 'liftReadsPrec' (without
-- requiring a 'Read1' instance).
--
-- This function is not available with @transformers-0.4@.
makeLiftReadsPrec :: Name -> Q Exp
makeLiftReadsPrec = makeReadPrecClass Read1 False

-- -- | Like 'makeLiftReadsPrec', but takes a 'ReadOptions' argument.
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadsPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeLiftReadsPrecOptions _ = makeReadPrecClass Read1 False
--
-- -- | Generates a lambda expression which behaves like 'liftReadList' (without
-- -- requiring a 'Read1' instance).
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadList :: Name -> Q Exp
-- makeLiftReadList = makeLiftReadListOptions defaultReadOptions
--
-- -- | Like 'makeLiftReadList', but takes a 'ReadOptions' argument.
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp
-- makeLiftReadListOptions = undefined

# if __GLASGOW_HASKELL__ >= 801
-- | Generates a lambda expression which behaves like 'liftReadPrec' (without
-- requiring a 'Read1' instance).
--
-- This function is only available with @base-4.10@ or later.
makeLiftReadPrec :: Name -> Q Exp
makeLiftReadPrec = makeReadPrecClass Read1 True

-- -- | Like 'makeLiftReadPrec', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeLiftReadPrecOptions _ = makeReadPrecClass Read1 True
--
-- -- | Generates a lambda expression which behaves like 'liftReadListPrec' (without
-- -- requiring a 'Read1' instance).
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadListPrec :: Name -> Q Exp
-- makeLiftReadListPrec = makeLiftReadListPrecOptions defaultReadOptions
--
-- -- | Like 'makeLiftReadListPrec', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadListPrecOptions :: ReadOptions -> Name -> Q Exp
-- makeLiftReadListPrecOptions = undefined

-- | Generates a lambda expression which behaves like 'readPrec1' (without
-- requiring a 'Read1' instance).
--
-- This function is only available with @base-4.10@ or later.
makeReadPrec1 :: Name -> Q Exp
makeReadPrec1 name = makeLiftReadPrec name
                     `appE` varE readPrecValName
                     `appE` varE readListPrecValName

-- -- | Like 'makeReadPrec1', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeReadPrec1Options :: ReadOptions -> Name -> Q Exp
-- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name
--                           `appE` varE readPrecValName
--                           `appE` varE readListPrecValName
# endif
-- | Generates a lambda expression which behaves like 'readsPrec1' (without
-- requiring a 'Read1' instance).
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 name = makeLiftReadsPrec name
                      `appE` varE readsPrecValName
                      `appE` varE readListValName

-- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument.
-- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp
-- makeReadsPrec1Options opts name = makeLiftReadsPrecOptions opts name
--                            `appE` varE readsPrecValName
--                            `appE` varE readListValName
#else
-- | Generates a lambda expression which behaves like 'readsPrec1' (without
-- requiring a 'Read1' instance).
makeReadsPrec1 :: Name -> Q Exp
makeReadsPrec1 = makeReadPrecClass Read1 False

-- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument.
-- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp
-- makeReadsPrec1Options _ = makeReadPrecClass Read1 False
#endif

#if defined(NEW_FUNCTOR_CLASSES)
-- | Generates a 'Read2' instance declaration for the given data type or data
-- family instance.
--
-- This function is not available with @transformers-0.4@.
deriveRead2 :: Name -> Q [Dec]
deriveRead2 = deriveRead2Options defaultReadOptions

-- | Like 'deriveRead2', but takes a 'ReadOptions' argument.
--
-- This function is not available with @transformers-0.4@.
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options = deriveReadClass Read2

-- | Generates a lambda expression which behaves like 'liftReadsPrec2' (without
-- requiring a 'Read2' instance).
--
-- This function is not available with @transformers-0.4@.
makeLiftReadsPrec2 :: Name -> Q Exp
makeLiftReadsPrec2 = makeReadPrecClass Read2 False

-- -- | Like 'makeLiftReadsPrec2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadsPrec2Options :: ReadOptions -> Name -> Q Exp
-- makeLiftReadsPrec2Options _ = makeReadPrecClass Read2 False
--
-- -- | Generates a lambda expression which behaves like 'liftReadList2' (without
-- -- requiring a 'Read2' instance).
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadList2 :: Name -> Q Exp
-- makeLiftReadList2 = makeLiftReadList2Options defaultReadOptions
--
-- -- | Like 'makeLiftReadList2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeLiftReadList2Options :: ReadOptions -> Name -> Q Exp
-- makeLiftReadList2Options opts name = do
--     let rp1Expr   = VarE `fmap` newName "rp1'"
--         rl1Expr   = VarE `fmap` newName "rl1'"
--         rp2Expr   = VarE `fmap` newName "rp2'"
--         rl2Expr   = VarE `fmap` newName "rl2'"
--     let rp2sExpr  = varE readPrec_to_SValName
--         rs2pExpr  = varE readS_to_PrecValName
--         constExpr = varE constValName
--     if shouldDefineReadPrec Read2 opts
--        then rp2sExpr
--             `appE` (makeLiftReadListPrec2Options opts name
--                     `appE` (rs2pExpr `appE` rp1Expr)
--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr))
--                     `appE` (rs2pExpr `appE` rp2Expr)
--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))
--             `appE` integerE 0
--        else rp2sExpr `appE` (varE listValName
--             `appE` (makeLiftReadPrec2Options opts name
--                     `appE` (rs2pExpr `appE` rp1Expr)
--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr))
--                     `appE` (rs2pExpr `appE` rp2Expr)
--                     `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr))))
--             `appE` integerE 0

# if __GLASGOW_HASKELL__ >= 801
-- | Generates a lambda expression which behaves like 'liftReadPrec2' (without
-- requiring a 'Read2' instance).
--
-- This function is only available with @base-4.10@ or later.
makeLiftReadPrec2 :: Name -> Q Exp
makeLiftReadPrec2 = makeReadPrecClass Read2 True

-- -- | Like 'makeLiftReadPrec2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadPrec2Options :: ReadOptions -> Name -> Q Exp
-- makeLiftReadPrec2Options _ = makeReadPrecClass Read2 True
--
-- -- | Generates a lambda expression which behaves like 'liftReadListPrec2' (without
-- -- requiring a 'Read2' instance).
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadListPrec2 :: Name -> Q Exp
-- makeLiftReadListPrec2 = makeLiftReadListPrec2Options defaultReadOptions
--
-- -- | Like 'makeLiftReadListPrec2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeLiftReadListPrec2Options :: ReadOptions -> Name -> Q Exp
-- makeLiftReadListPrec2Options = undefined

-- | Generates a lambda expression which behaves like 'readPrec2' (without
-- requiring a 'Read2' instance).
--
-- This function is only available with @base-4.10@ or later.
makeReadPrec2 :: Name -> Q Exp
makeReadPrec2 name = makeLiftReadPrec2 name
                     `appE` varE readPrecValName
                     `appE` varE readListPrecValName
                     `appE` varE readPrecValName
                     `appE` varE readListPrecValName

-- -- | Like 'makeReadPrec2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is only available with @base-4.10@ or later.
-- makeReadPrec2Options :: ReadOptions -> Name -> Q Exp
-- makeReadPrec2Options opts name = makeLiftReadPrec2Options opts name
--                           `appE` varE readPrecValName
--                           `appE` varE readListPrecValName
--                           `appE` varE readPrecValName
--                           `appE` varE readListPrecValName
# endif

-- | Generates a lambda expression which behaves like 'readsPrec2' (without
-- requiring a 'Read2' instance).
--
-- This function is not available with @transformers-0.4@.
makeReadsPrec2 :: Name -> Q Exp
makeReadsPrec2 name = makeLiftReadsPrec2 name
                      `appE` varE readsPrecValName
                      `appE` varE readListValName
                      `appE` varE readsPrecValName
                      `appE` varE readListValName

-- -- | Like 'makeReadsPrec2', but takes a 'ReadOptions' argument.
-- --
-- -- This function is not available with @transformers-0.4@.
-- makeReadsPrec2Options :: ReadOptions -> Name -> Q Exp
-- makeReadsPrec2Options opts name = makeLiftReadsPrec2Options opts name
--                           `appE` varE readsPrecValName
--                           `appE` varE readListValName
--                           `appE` varE readsPrecValName
--                           `appE` varE readListValName
#endif

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Derive a Read(1)(2) instance declaration (depending on the ReadClass
-- argument's value).
deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass rClass opts 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 rClass name' ctxt tvbs mbTys
        instanceD (return instanceCxt)
                  (return instanceType)
                  (readPrecDecs rClass opts cons)

-- | Generates a declaration defining the primary function corresponding to a
-- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and
-- liftRead(s)Prec2 for Read2).
readPrecDecs :: ReadClass -> ReadOptions -> [Con] -> [Q Dec]
readPrecDecs rClass opts cons =
    [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass)
           [ clause []
                    (normalB $ makeReadForCons rClass defineReadPrec cons)
                    []
           ]
    ] ++ if defineReadPrec
            then [ funD (readListPrecName rClass)
                        [ clause []
                                 (normalB . varE $ readListPrecDefaultName rClass)
                                 []
                        ]
                 ]
            else []
  where
    defineReadPrec :: Bool
    defineReadPrec = shouldDefineReadPrec rClass opts

-- | Generates a lambda expression which behaves like read(s)Prec (for Read),
-- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2).
makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass rClass urp name = withType name fromCons
  where
    fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
    fromCons name' ctxt tvbs cons mbTys =
        -- We force buildTypeInstance here since it performs some checks for whether
        -- or not the provided datatype can actually have
        -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors
        -- if it can't.
        buildTypeInstance rClass name' ctxt tvbs mbTys
          `seq` makeReadForCons rClass urp cons

-- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the
-- given constructors. All constructors must be from the same type.
makeReadForCons :: ReadClass -> Bool -> [Con] -> Q Exp
makeReadForCons rClass urp cons = do
    p   <- newName "p"
    rps <- newNameList "rp" $ arity rClass
    rls <- newNameList "rl" $ arity rClass
    let rpls       = zip rps rls
        _rpsAndRls = interleave rps rls

    let nullaryCons, nonNullaryCons :: [Con]
        (nullaryCons, nonNullaryCons) = partition isNullaryCon cons

        readConsExpr :: Q Exp
        readConsExpr
          | null cons = varE pfailValName
          | otherwise = do
                readNonNullaryCons <- concatMapM (makeReadForCon rClass urp rpls)
                                                 nonNullaryCons
                foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons)

        readNullaryCons :: [Q Exp]
        readNullaryCons = case nullaryCons of
          []    -> []
          [con]
            | nameBase (constructorName con) == "()"
           -> [varE parenValName `appE`
                    mkDoStmts [] (varE returnValName `appE` tupE [])]
            | otherwise -> [mkDoStmts (matchCon con)
                                      (resultExpr (constructorName con) [])]
          _     -> [varE chooseValName `appE` listE (map mkPair nullaryCons)]

        mkAlt :: Q Exp -> Q Exp -> Q Exp
        mkAlt e1 e2 = infixApp e1 (varE altValName) e2

        mkPair :: Con -> Q Exp
        mkPair con = tupE [ stringE $ dataConStr con
                          , resultExpr (constructorName con) []
                          ]

        matchCon :: Con -> [Q Stmt]
        matchCon con
          | isSym conStr = [symbolPat conStr]
          | otherwise    = identHPat conStr
          where
            conStr = dataConStr con

        mainRhsExpr :: Q Exp
        mainRhsExpr = varE parensValName `appE` readConsExpr

    lamE (map varP $
#if defined(NEW_FUNCTOR_CLASSES)
                     _rpsAndRls ++
#endif
                     if urp then [] else [p]
         ) . appsE
         $ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass
           , if urp
                then mainRhsExpr
                else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p
           ]
#if defined(NEW_FUNCTOR_CLASSES)
             ++ map varE _rpsAndRls
#endif
             ++ if urp then [] else [varE p]

makeReadForCon :: ReadClass
               -> Bool
               -> [(Name, Name)]
               -> Con
               -> Q [Exp]
makeReadForCon rClass urp rpls (NormalC conName _)  = do
    (argTys, tvMap) <- reifyConTys2 rClass rpls conName
    args <- newNameList "arg" $ length argTys
    let conStr = nameBase conName
        isTup  = isNonUnitTupleString conStr
    (readStmts, varExps) <-
        zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys args
    let body = resultExpr conName varExps

    e <- if isTup
            then let tupleStmts = intersperse (readPunc ",") readStmts
                 in varE parenValName `appE` mkDoStmts tupleStmts body
            else let prefixStmts = readPrefixCon conStr ++ readStmts
                 in mkParser appPrec prefixStmts body
    return [e]
makeReadForCon rClass urp rpls (RecC conName ts) = do
    (argTys, tvMap) <- reifyConTys2 rClass rpls conName
    args <- newNameList "arg" $ length argTys
    (readStmts, varExps) <- zipWith3AndUnzipM
        (\(argName, _, _) argTy arg -> makeReadForField rClass urp tvMap conName
                                           (nameBase argName) argTy arg)
        ts argTys args
    let body        = resultExpr conName varExps
        conStr      = nameBase conName
        recordStmts = readPrefixCon conStr ++ [readPunc "{"]
                      ++ concat (intersperse [readPunc ","] readStmts)
                      ++ [readPunc "}"]

    e <- mkParser appPrec1 recordStmts body
    return [e]
makeReadForCon rClass urp rpls (InfixC _ conName _) = do
    ([alTy, arTy], tvMap) <- reifyConTys2 rClass rpls conName
    al   <- newName "argL"
    ar   <- newName "argR"
    ([readStmt1, readStmt2], varExps) <-
        zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName)
                         [alTy, arTy] [al, ar]
    info <- reify conName

#if MIN_VERSION_template_haskell(2,11,0)
    conPrec <- case info of
                        DataConI{} -> do
                            fi <- fromMaybe defaultFixity <$> reifyFixity conName
                            case fi of
                                 Fixity prec _ -> return prec
#else
    let conPrec  = case info of
                        DataConI _ _ _ (Fixity prec _) -> prec
#endif
                        _ -> error $ "Text.Read.Deriving.Internal.makeReadForCon: Unsupported type: " ++ show info

    let body   = resultExpr conName varExps
        conStr = nameBase conName
        readInfixCon
          | isSym conStr = [symbolPat conStr]
          | otherwise    = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"]
        infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2]

    e <- mkParser conPrec infixStmts body
    return [e]
makeReadForCon rClass urp rpls (ForallC _ _ con) =
    makeReadForCon rClass urp rpls con
#if MIN_VERSION_template_haskell(2,11,0)
makeReadForCon rClass urp rpls (GadtC conNames ts _) =
    let con :: Name -> Q Con
        con conName = do
            mbFi <- reifyFixity conName
            return $ if isInfixDataCon (nameBase conName)
                        && length ts == 2
                        && isJust mbFi
                      then let [t1, t2] = ts in InfixC t1 conName t2
                      else NormalC conName ts

    in concatMapM (makeReadForCon rClass urp rpls <=< con) conNames
makeReadForCon rClass urp rpls (RecGadtC conNames ts _) =
    concatMapM (makeReadForCon rClass urp rpls . flip RecC ts) conNames
#endif

makeReadForArg :: ReadClass
               -> Bool
               -> Bool
               -> TyVarMap2
               -> Name
               -> Type
               -> Name
               -> Q (Q Stmt, Exp)
makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do
    (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty
    let readStmt = bindS (varP tyExpName) $
                         (if (not isTup) then appE (varE stepValName) else id) $
                            wrapReadS urp (return rExp)
    return (readStmt, varExp)

makeReadForField :: ReadClass
                 -> Bool
                 -> TyVarMap2
                 -> Name
                 -> String
                 -> Type
                 -> Name
                 -> Q ([Q Stmt], Exp)
makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do
    (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty
    let readStmt = bindS (varP tyExpName) $
                         varE resetValName `appE` wrapReadS urp (return rExp)
    return (readLbl ++ [readPunc "=", readStmt], varExp)
  where
    readLbl | isSym lblStr
            = [readPunc "(", symbolPat lblStr, readPunc ")"]
            | otherwise
            = identHPat lblStr

makeReadForType :: ReadClass
                -> Bool
                -> TyVarMap2
                -> Name
                -> Name
                -> Bool
                -> Type
                -> Q (Exp, Exp)
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) =
    let tyExp = VarE tyExpName
    in return $ case Map.lookup tyName tvMap of
      Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp)
      Nothing                     -> (VarE $ readsOrReadName urp rl Read, tyExp)
#else
makeReadForType _ urp _ _ tyExpName _ VarT{} =
    return (VarE $ readsOrReadName urp False Read, VarE tyExpName)
#endif
makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) =
    makeReadForType rClass urp tvMap conName tyExpName rl ty
makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) =
    makeReadForType rClass urp tvMap conName tyExpName rl ty
#if defined(NEW_FUNCTOR_CLASSES)
makeReadForType rClass urp tvMap conName tyExpName rl ty = do
    let tyCon :: Type
        tyArgs :: [Type]
        tyCon:tyArgs = unapplyTy ty

        numLastArgs :: Int
        numLastArgs = min (arity rClass) (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 rClass conName
       else if any (`mentionsName` tyVarNames) rhsArgs
               then do
                 readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs]
                            ++ zipWith (\b -> fmap fst
                                            . makeReadForType rClass urp tvMap conName tyExpName b)
                                       (cycle [False,True])
                                       (interleave rhsArgs rhsArgs)
                 return (readExp, VarE tyExpName)
               else return (VarE $ readsOrReadName urp rl Read, VarE tyExpName)
#else
makeReadForType rClass urp tvMap conName tyExpName _ ty = do
  let varNames = Map.keys tvMap
      rpExpr   = VarE $ readsOrReadName urp False Read
      rp1Expr  = VarE $ readsOrReadName urp False Read1
      tyExpr   = VarE tyExpName

  case varNames of
    [] -> return (rpExpr, tyExpr)
    varName:_ -> do
      if mentionsName ty varNames
         then do
             applyExp <- makeFmapApplyPos rClass conName ty varName
             return (rp1Expr, applyExp `AppE` tyExpr)
         else return (rpExpr, tyExpr)
#endif

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which @Read@ variant is being derived.
data ReadClass = Read
               | Read1
#if defined(NEW_FUNCTOR_CLASSES)
               | Read2
#endif
  deriving (Bounded, Enum)

instance ClassRep ReadClass where
    arity = fromEnum

    allowExQuant _ = False

    fullClassName Read  = readTypeName
    fullClassName Read1 = read1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
    fullClassName Read2 = read2TypeName
#endif

    classConstraint rClass i
      | rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass)
      | otherwise              = Nothing
      where
        rMin, rMax :: Int
        rMin = fromEnum (minBound :: ReadClass)
        rMax = fromEnum rClass

readsPrecConstName :: ReadClass -> Name
readsPrecConstName Read  = readsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecConstName Read1 = liftReadsPrecConstValName
readsPrecConstName Read2 = liftReadsPrec2ConstValName
#else
readsPrecConstName Read1 = readsPrec1ConstValName
#endif

readPrecConstName :: ReadClass -> Name
readPrecConstName Read  = readPrecConstValName
readPrecConstName Read1 = liftReadPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecConstName Read2 = liftReadPrec2ConstValName
#endif

readsPrecName :: ReadClass -> Name
readsPrecName Read  = readsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecName Read1 = liftReadsPrecValName
readsPrecName Read2 = liftReadsPrec2ValName
#else
readsPrecName Read1 = readsPrec1ValName
#endif

readPrecName :: ReadClass -> Name
readPrecName Read  = readPrecValName
readPrecName Read1 = liftReadPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readPrecName Read2 = liftReadPrec2ValName
#endif

readListPrecDefaultName :: ReadClass -> Name
readListPrecDefaultName Read  = readListPrecDefaultValName
readListPrecDefaultName Read1 = liftReadListPrecDefaultValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName
#endif

readListPrecName :: ReadClass -> Name
readListPrecName Read  = readListPrecValName
readListPrecName Read1 = liftReadListPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
readListPrecName Read2 = liftReadListPrec2ValName
#endif

readListName :: ReadClass -> Name
readListName Read  = readListValName
#if defined(NEW_FUNCTOR_CLASSES)
readListName Read1 = liftReadListValName
readListName Read2 = liftReadList2ValName
#else
readListName Read1 = error "Text.Read.Deriving.Internal.readListName"
#endif

readsPrecOrListName :: Bool -- ^ readsListName if True, readsPrecName if False
                    -> ReadClass
                    -> Name
readsPrecOrListName False = readsPrecName
readsPrecOrListName True  = readListName

readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False
                   -> ReadClass
                   -> Name
readPrecOrListName False = readPrecName
readPrecOrListName True  = readListPrecName

readsOrReadName :: Bool -- ^ readPrecOrListName if True, readsPrecOrListName if False
                -> Bool -- ^ read(s)List(Prec)Name if True, read(s)PrecName if False
                -> ReadClass
                -> Name
readsOrReadName False = readsPrecOrListName
readsOrReadName True  = readPrecOrListName

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b

mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts ss b = doE (ss ++ [noBindS b])

resultExpr :: Name -> [Exp] -> Q Exp
resultExpr conName as = varE returnValName `appE` conApp
  where
    conApp :: Q Exp
    conApp = appsE $ conE conName : map return as

identHPat :: String -> [Q Stmt]
identHPat s
    | Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"]
    | otherwise                    = [identPat s]

bindLex :: Q Exp -> Q Stmt
bindLex pat = noBindS $ varE expectPValName `appE` pat

identPat :: String -> Q Stmt
identPat s = bindLex $ conE identDataName `appE` stringE s

symbolPat :: String -> Q Stmt
symbolPat s = bindLex $ conE symbolDataName `appE` stringE s

readPunc :: String -> Q Stmt
readPunc c = bindLex $ conE puncDataName `appE` stringE c

snocView :: [a] -> Maybe ([a],a)
        -- Split off the last element
snocView [] = Nothing
snocView xs = go [] xs
  where
      -- Invariant: second arg is non-empty
    go acc [a]    = Just (reverse acc, a)
    go acc (a:as) = go (a:acc) as
    go _   []     = error "Util: snocView"

dataConStr :: Con -> String
dataConStr = nameBase . constructorName

readPrefixCon :: String -> [Q Stmt]
readPrefixCon conStr
  | isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"]
  | otherwise    = identHPat conStr

wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS urp e = if urp then e
                         else varE readS_to_PrecValName `appE` e

shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible
  where
    base4'10OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 801
    base4'10OrLater = True
#else
    base4'10OrLater = False
#endif

    baseCompatible :: Bool
    baseCompatible = case rClass of
        Read  -> True
        Read1 -> base4'10OrLater
#if defined(NEW_FUNCTOR_CLASSES)
        Read2 -> base4'10OrLater
#endif