{-# 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.

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 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

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

import           GHC.Show (appPrec, appPrec1)

import           Language.Haskell.TH.Datatype
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
  { ReadOptions -> Bool
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 (ReadOptions -> ReadOptions -> Bool
(ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool) -> Eq ReadOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadOptions -> ReadOptions -> Bool
$c/= :: ReadOptions -> ReadOptions -> Bool
== :: ReadOptions -> ReadOptions -> Bool
$c== :: ReadOptions -> ReadOptions -> Bool
Eq, Eq ReadOptions
Eq ReadOptions
-> (ReadOptions -> ReadOptions -> Ordering)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> Bool)
-> (ReadOptions -> ReadOptions -> ReadOptions)
-> (ReadOptions -> ReadOptions -> ReadOptions)
-> Ord ReadOptions
ReadOptions -> ReadOptions -> Bool
ReadOptions -> ReadOptions -> Ordering
ReadOptions -> ReadOptions -> ReadOptions
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadOptions -> ReadOptions -> ReadOptions
$cmin :: ReadOptions -> ReadOptions -> ReadOptions
max :: ReadOptions -> ReadOptions -> ReadOptions
$cmax :: ReadOptions -> ReadOptions -> ReadOptions
>= :: ReadOptions -> ReadOptions -> Bool
$c>= :: ReadOptions -> ReadOptions -> Bool
> :: ReadOptions -> ReadOptions -> Bool
$c> :: ReadOptions -> ReadOptions -> Bool
<= :: ReadOptions -> ReadOptions -> Bool
$c<= :: ReadOptions -> ReadOptions -> Bool
< :: ReadOptions -> ReadOptions -> Bool
$c< :: ReadOptions -> ReadOptions -> Bool
compare :: ReadOptions -> ReadOptions -> Ordering
$ccompare :: ReadOptions -> ReadOptions -> Ordering
$cp1Ord :: Eq ReadOptions
Ord, ReadPrec [ReadOptions]
ReadPrec ReadOptions
Int -> ReadS ReadOptions
ReadS [ReadOptions]
(Int -> ReadS ReadOptions)
-> ReadS [ReadOptions]
-> ReadPrec ReadOptions
-> ReadPrec [ReadOptions]
-> Read ReadOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadOptions]
$creadListPrec :: ReadPrec [ReadOptions]
readPrec :: ReadPrec ReadOptions
$creadPrec :: ReadPrec ReadOptions
readList :: ReadS [ReadOptions]
$creadList :: ReadS [ReadOptions]
readsPrec :: Int -> ReadS ReadOptions
$creadsPrec :: Int -> ReadS ReadOptions
Read, Int -> ReadOptions -> ShowS
[ReadOptions] -> ShowS
ReadOptions -> String
(Int -> ReadOptions -> ShowS)
-> (ReadOptions -> String)
-> ([ReadOptions] -> ShowS)
-> Show ReadOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadOptions] -> ShowS
$cshowList :: [ReadOptions] -> ShowS
show :: ReadOptions -> String
$cshow :: ReadOptions -> String
showsPrec :: Int -> ReadOptions -> ShowS
$cshowsPrec :: Int -> ReadOptions -> ShowS
Show)

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

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

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

-- | Generates a lambda expression which behaves like 'readsPrec' (without
-- requiring a 'Read' instance).
makeReadsPrec :: Name -> Q Exp
makeReadsPrec :: Name -> Q Exp
makeReadsPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read Bool
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 :: Name -> Q Exp
makeReadPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read Bool
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 :: Name -> Q [Dec]
deriveRead1 = ReadOptions -> Name -> Q [Dec]
deriveRead1Options ReadOptions
defaultReadOptions

-- | Like 'deriveRead1', but takes a 'ReadOptions' argument.
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options :: ReadOptions -> Name -> Q [Dec]
deriveRead1Options = ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
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 :: Name -> Q Exp
makeLiftReadsPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read1 Bool
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 :: Name -> Q Exp
makeLiftReadPrec = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read1 Bool
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 -> Q Exp
makeReadPrec1 Name
name = Name -> Q Exp
makeLiftReadPrec Name
name
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
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 -> Q Exp
makeReadsPrec1 Name
name = Name -> Q Exp
makeLiftReadsPrec Name
name
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
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 :: Name -> Q [Dec]
deriveRead2 = ReadOptions -> Name -> Q [Dec]
deriveRead2Options ReadOptions
defaultReadOptions

-- | Like 'deriveRead2', but takes a 'ReadOptions' argument.
--
-- This function is not available with @transformers-0.4@.
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options :: ReadOptions -> Name -> Q [Dec]
deriveRead2Options = ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
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 :: Name -> Q Exp
makeLiftReadsPrec2 = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read2 Bool
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 :: Name -> Q Exp
makeLiftReadPrec2 = ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
Read2 Bool
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 -> Q Exp
makeReadPrec2 Name
name = Name -> Q Exp
makeLiftReadPrec2 Name
name
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListPrecValName
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readPrecValName
                     Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
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 -> Q Exp
makeReadsPrec2 Name
name = Name -> Q Exp
makeLiftReadsPrec2 Name
name
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readListValName
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
readsPrecValName
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
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 :: ReadClass -> ReadOptions -> Name -> Q [Dec]
deriveReadClass ReadClass
rClass ReadOptions
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      (Cxt
instanceCxt, Type
instanceType)
          <- ReadClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                             (ReadClass -> ReadOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
readPrecDecs ReadClass
rClass ReadOptions
opts Cxt
instTypes [ConstructorInfo]
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 -> [Type] -> [ConstructorInfo] -> [Q Dec]
readPrecDecs :: ReadClass -> ReadOptions -> Cxt -> [ConstructorInfo] -> [Q Dec]
readPrecDecs ReadClass
rClass ReadOptions
opts Cxt
instTypes [ConstructorInfo]
cons =
    [ Name -> [ClauseQ] -> Q Dec
funD ((if Bool
defineReadPrec then ReadClass -> Name
readPrecName else ReadClass -> Name
readsPrecName) ReadClass
rClass)
           [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
defineReadPrec Cxt
instTypes [ConstructorInfo]
cons)
                    []
           ]
    ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ if Bool
defineReadPrec
            then [ Name -> [ClauseQ] -> Q Dec
funD (ReadClass -> Name
readListPrecName ReadClass
rClass)
                        [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                                 (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> (Name -> Q Exp) -> Name -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> BodyQ) -> Name -> BodyQ
forall a b. (a -> b) -> a -> b
$ ReadClass -> Name
readListPrecDefaultName ReadClass
rClass)
                                 []
                        ]
                 ]
            else []
  where
    defineReadPrec :: Bool
    defineReadPrec :: Bool
defineReadPrec = ReadClass -> ReadOptions -> Bool
shouldDefineReadPrec ReadClass
rClass ReadOptions
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 :: ReadClass -> Bool -> Name -> Q Exp
makeReadPrecClass ReadClass
rClass Bool
urp Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext   = Cxt
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
                 , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      -- 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.
      ReadClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance ReadClass
rClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
        Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
urp Cxt
instTypes [ConstructorInfo]
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 -> [Type] -> [ConstructorInfo] -> Q Exp
makeReadForCons :: ReadClass -> Bool -> Cxt -> [ConstructorInfo] -> Q Exp
makeReadForCons ReadClass
rClass Bool
urp Cxt
instTypes [ConstructorInfo]
cons = do
    Name
p   <- String -> Q Name
newName String
"p"
    [Name]
rps <- String -> Int -> Q [Name]
newNameList String
"rp" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass
    [Name]
rls <- String -> Int -> Q [Name]
newNameList String
"rl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass
    let rpls :: [(Name, Name)]
rpls       = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
rps [Name]
rls
        _rpsAndRls :: [Name]
_rpsAndRls = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
rps [Name]
rls
        lastTyVars :: [Name]
lastTyVars = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName (Cxt -> [Name]) -> Cxt -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
instTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum ReadClass
rClass) Cxt
instTypes
        rplMap :: Map Name (OneOrTwoNames Two)
rplMap     = [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two))
-> [(Name, OneOrTwoNames Two)] -> Map Name (OneOrTwoNames Two)
forall a b. (a -> b) -> a -> b
$ (Name -> (Name, Name) -> (Name, OneOrTwoNames Two))
-> [Name] -> [(Name, Name)] -> [(Name, OneOrTwoNames Two)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
x (Name
y, Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
rpls

    let nullaryCons, nonNullaryCons :: [ConstructorInfo]
        ([ConstructorInfo]
nullaryCons, [ConstructorInfo]
nonNullaryCons) = (ConstructorInfo -> Bool)
-> [ConstructorInfo] -> ([ConstructorInfo], [ConstructorInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstructorInfo -> Bool
isNullaryCon [ConstructorInfo]
cons

        readConsExpr :: Q Exp
        readConsExpr :: Q Exp
readConsExpr = do
          [Exp]
readNonNullaryCons <- (ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ReadClass
-> Bool -> Map Name (OneOrTwoNames Two) -> ConstructorInfo -> Q Exp
makeReadForCon ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
rplMap)
                                     [ConstructorInfo]
nonNullaryCons
          (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
mkAlt ([Q Exp]
readNullaryCons [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
readNonNullaryCons)

        readNullaryCons :: [Q Exp]
        readNullaryCons :: [Q Exp]
readNullaryCons = case [ConstructorInfo]
nullaryCons of
          [] -> []
          [ConstructorInfo
con]
            | Name -> String
nameBase (ConstructorInfo -> Name
constructorName ConstructorInfo
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"()"
           -> [Name -> Q Exp
varE Name
parenValName Q Exp -> Q Exp -> Q Exp
`appE`
                    [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [] (Name -> Q Exp
varE Name
returnValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [])]
            | Bool
otherwise -> [[Q Stmt] -> Q Exp -> Q Exp
mkDoStmts (ConstructorInfo -> [Q Stmt]
matchCon ConstructorInfo
con)
                                      (Name -> [Exp] -> Q Exp
resultExpr (ConstructorInfo -> Name
constructorName ConstructorInfo
con) [])]
          [ConstructorInfo]
_ -> [Name -> Q Exp
varE Name
chooseValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
listE ((ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Exp
mkPair [ConstructorInfo]
nullaryCons)]

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

        mkPair :: ConstructorInfo -> Q Exp
        mkPair :: ConstructorInfo -> Q Exp
mkPair ConstructorInfo
con = [Q Exp] -> Q Exp
tupE [ String -> Q Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> String
dataConStr ConstructorInfo
con
                          , Name -> [Exp] -> Q Exp
resultExpr (ConstructorInfo -> Name
constructorName ConstructorInfo
con) []
                          ]

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

        mainRhsExpr :: Q Exp
        mainRhsExpr :: Q Exp
mainRhsExpr
          | [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
cons = Name -> Q Exp
varE Name
pfailValName
          | Bool
otherwise = Name -> Q Exp
varE Name
parensValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
readConsExpr

    [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$
#if defined(NEW_FUNCTOR_CLASSES)
                     [Name]
_rpsAndRls [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
#endif
                     if Bool
urp then [] else [Name
p]
         ) (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
appsE
         ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ (if Bool
urp then ReadClass -> Name
readPrecConstName else ReadClass -> Name
readsPrecConstName) ReadClass
rClass
           , if Bool
urp
                then Q Exp
mainRhsExpr
                else Name -> Q Exp
varE Name
readPrec_to_SValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
mainRhsExpr Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
p
           ]
#if defined(NEW_FUNCTOR_CLASSES)
             [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
_rpsAndRls
#endif
             [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ if Bool
urp then [] else [Name -> Q Exp
varE Name
p]

makeReadForCon :: ReadClass
               -> Bool
               -> TyVarMap2
               -> ConstructorInfo
               -> Q Exp
makeReadForCon :: ReadClass
-> Bool -> Map Name (OneOrTwoNames Two) -> ConstructorInfo -> Q Exp
makeReadForCon ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
argTys }) = do
    Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
    [Name]
args    <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
    let conStr :: String
conStr = Name -> String
nameBase Name
conName
        isTup :: Bool
isTup  = String -> Bool
isNonUnitTupleString String
conStr
    ([Q Stmt]
readStmts, [Exp]
varExps) <-
        (Type -> Name -> Q (Q Stmt, Exp))
-> Cxt -> [Name] -> Q ([Q Stmt], [Exp])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM (ReadClass
-> Bool
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg ReadClass
rClass Bool
isTup Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName) Cxt
argTys' [Name]
args
    let body :: Q Exp
body = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps

    ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
      if Bool
isTup
         then let tupleStmts :: [Q Stmt]
tupleStmts = Q Stmt -> [Q Stmt] -> [Q Stmt]
forall a. a -> [a] -> [a]
intersperse (String -> Q Stmt
readPunc String
",") [Q Stmt]
readStmts
              in Name -> Q Exp
varE Name
parenValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Stmt] -> Q Exp -> Q Exp
mkDoStmts [Q Stmt]
tupleStmts Q Exp
body
         else let prefixStmts :: [Q Stmt]
prefixStmts = String -> [Q Stmt]
readPrefixCon String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
readStmts
              in Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
appPrec [Q Stmt]
prefixStmts Q Exp
body
makeReadForCon ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
argNames
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
argTys }) = do
    Cxt
argTys' <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
    [Name]
args    <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
argTys'
    ([[Q Stmt]]
readStmts, [Exp]
varExps) <- (Name -> Type -> Name -> Q ([Q Stmt], Exp))
-> [Name] -> Cxt -> [Name] -> Q ([[Q Stmt]], [Exp])
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e])
zipWith3AndUnzipM
        (\Name
argName Type
argTy Name
arg -> ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName
                                           (Name -> String
nameBase Name
argName) Type
argTy Name
arg)
        [Name]
argNames Cxt
argTys' [Name]
args
    let body :: Q Exp
body        = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps
        conStr :: String
conStr      = Name -> String
nameBase Name
conName
        recordStmts :: [Q Stmt]
recordStmts = String -> [Q Stmt]
readPrefixCon String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"{"]
                      [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [[Q Stmt]] -> [Q Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Q Stmt] -> [[Q Stmt]] -> [[Q Stmt]]
forall a. a -> [a] -> [a]
intersperse [String -> Q Stmt
readPunc String
","] [[Q Stmt]]
readStmts)
                      [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"}"]

    ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
      Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
appPrec1 [Q Stmt]
recordStmts Q Exp
body
makeReadForCon ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
                   , constructorFields :: ConstructorInfo -> Cxt
constructorFields  = Cxt
argTys }) = do
    [Type
alTy, Type
arTy] <- (Type -> TypeQ) -> Cxt -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms Cxt
argTys
    Name
al <- String -> Q Name
newName String
"argL"
    Name
ar <- String -> Q Name
newName String
"argR"
    Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
    ([Q Stmt
readStmt1, Q Stmt
readStmt2], [Exp]
varExps) <-
        (Type -> Name -> Q (Q Stmt, Exp))
-> Cxt -> [Name] -> Q ([Q Stmt], [Exp])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
zipWithAndUnzipM (ReadClass
-> Bool
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Type
-> Name
-> Q (Q Stmt, Exp)
makeReadForArg ReadClass
rClass Bool
False Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName)
                         [Type
alTy, Type
arTy] [Name
al, Name
ar]

    let conPrec :: Int
conPrec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
        body :: Q Exp
body    = Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
varExps
        conStr :: String
conStr  = Name -> String
nameBase Name
conName
        readInfixCon :: [Q Stmt]
readInfixCon
          | String -> Bool
isSym String
conStr = [String -> Q Stmt
symbolPat String
conStr]
          | Bool
otherwise    = [String -> Q Stmt
readPunc String
"`"] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ String -> [Q Stmt]
identHPat String
conStr [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc String
"`"]
        infixStmts :: [Q Stmt]
infixStmts = [Q Stmt
readStmt1] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt]
readInfixCon [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [Q Stmt
readStmt2]

    ReadClass
-> Map Name (OneOrTwoNames Two) -> Cxt -> Name -> Q Exp -> Q Exp
forall a b c.
ClassRep a =>
a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
checkExistentialContext ReadClass
rClass Map Name (OneOrTwoNames Two)
tvMap Cxt
ctxt Name
conName (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
      Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser Int
conPrec [Q Stmt]
infixStmts Q Exp
body

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

makeReadForField :: ReadClass
                 -> Bool
                 -> TyVarMap2
                 -> Name
                 -> String
                 -> Type
                 -> Name
                 -> Q ([Q Stmt], Exp)
makeReadForField :: ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> String
-> Type
-> Name
-> Q ([Q Stmt], Exp)
makeReadForField ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName String
lblStr Type
ty Name
tyExpName = do
    (Exp
rExp, Exp
varExp) <- ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
False Type
ty
    let readStmt :: Q Stmt
readStmt = PatQ -> Q Exp -> Q Stmt
bindS (Name -> PatQ
varP Name
tyExpName) (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$
                     Q Exp
read_field Q Exp -> Q Exp -> Q Exp
`appE`
                     (Name -> Q Exp
varE Name
resetValName Q Exp -> Q Exp -> Q Exp
`appE` Bool -> Q Exp -> Q Exp
wrapReadS Bool
urp (Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rExp))
    ([Q Stmt], Exp) -> Q ([Q Stmt], Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Q Stmt
readStmt], Exp
varExp)
  where
    mk_read_field :: Name -> String -> Q Exp
mk_read_field Name
readFieldName String
lbl
      = Name -> Q Exp
varE Name
readFieldName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
lbl
    read_field :: Q Exp
read_field
      | String -> Bool
isSym String
lblStr
      = Name -> String -> Q Exp
mk_read_field Name
readSymFieldValName String
lblStr
      | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
lblStr
      = Name -> String -> Q Exp
mk_read_field Name
readFieldHashValName String
ss
      | Bool
otherwise
      = Name -> String -> Q Exp
mk_read_field Name
readFieldValName String
lblStr

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

        numLastArgs :: Int
        numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (ReadClass -> Int
forall a. ClassRep a => a -> Int
arity ReadClass
rClass) (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        (Cxt
lhsArgs, Cxt
rhsArgs) = Int -> Cxt -> (Cxt, Cxt)
forall a. Int -> [a] -> ([a], [a])
splitAt (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) Cxt
tyArgs

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = Map Name (OneOrTwoNames Two) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (OneOrTwoNames Two)
tvMap

    Bool
itf <- [Name] -> Type -> Cxt -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon Cxt
tyArgs
    if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
lhsArgs
          Bool -> Bool -> Bool
|| Bool
itf Bool -> Bool -> Bool
&& (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
tyArgs
       then ReadClass -> Name -> Q (Exp, Exp)
forall a b. ClassRep a => a -> Name -> Q b
outOfPlaceTyVarError ReadClass
rClass Name
conName
       else if (Type -> Bool) -> Cxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) Cxt
rhsArgs
               then do
                 Exp
readExp <- [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [ Name -> Q Exp
varE (Name -> Q Exp) -> (ReadClass -> Name) -> ReadClass -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl (ReadClass -> Q Exp) -> ReadClass -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> ReadClass
forall a. Enum a => Int -> a
toEnum Int
numLastArgs]
                            [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Bool -> Type -> Q Exp) -> [Bool] -> Cxt -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Bool
b -> ((Exp, Exp) -> Exp) -> Q (Exp, Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp, Exp) -> Exp
forall a b. (a, b) -> a
fst
                                            (Q (Exp, Exp) -> Q Exp) -> (Type -> Q (Exp, Exp)) -> Type -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadClass
-> Bool
-> Map Name (OneOrTwoNames Two)
-> Name
-> Name
-> Bool
-> Type
-> Q (Exp, Exp)
makeReadForType ReadClass
rClass Bool
urp Map Name (OneOrTwoNames Two)
tvMap Name
conName Name
tyExpName Bool
b)
                                       ([Bool] -> [Bool]
forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
                                       (Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
interleave Cxt
rhsArgs Cxt
rhsArgs)
                 (Exp, Exp) -> Q (Exp, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
readExp, Name -> Exp
VarE Name
tyExpName)
               else (Exp, Exp) -> Q (Exp, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
urp Bool
rl ReadClass
Read, Name -> Exp
VarE Name
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 (ReadClass
ReadClass -> ReadClass -> Bounded ReadClass
forall a. a -> a -> Bounded a
maxBound :: ReadClass
$cmaxBound :: ReadClass
minBound :: ReadClass
$cminBound :: ReadClass
Bounded, Int -> ReadClass
ReadClass -> Int
ReadClass -> [ReadClass]
ReadClass -> ReadClass
ReadClass -> ReadClass -> [ReadClass]
ReadClass -> ReadClass -> ReadClass -> [ReadClass]
(ReadClass -> ReadClass)
-> (ReadClass -> ReadClass)
-> (Int -> ReadClass)
-> (ReadClass -> Int)
-> (ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> [ReadClass])
-> (ReadClass -> ReadClass -> ReadClass -> [ReadClass])
-> Enum ReadClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReadClass -> ReadClass -> ReadClass -> [ReadClass]
$cenumFromThenTo :: ReadClass -> ReadClass -> ReadClass -> [ReadClass]
enumFromTo :: ReadClass -> ReadClass -> [ReadClass]
$cenumFromTo :: ReadClass -> ReadClass -> [ReadClass]
enumFromThen :: ReadClass -> ReadClass -> [ReadClass]
$cenumFromThen :: ReadClass -> ReadClass -> [ReadClass]
enumFrom :: ReadClass -> [ReadClass]
$cenumFrom :: ReadClass -> [ReadClass]
fromEnum :: ReadClass -> Int
$cfromEnum :: ReadClass -> Int
toEnum :: Int -> ReadClass
$ctoEnum :: Int -> ReadClass
pred :: ReadClass -> ReadClass
$cpred :: ReadClass -> ReadClass
succ :: ReadClass -> ReadClass
$csucc :: ReadClass -> ReadClass
Enum)

instance ClassRep ReadClass where
    arity :: ReadClass -> Int
arity = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum

    allowExQuant :: ReadClass -> Bool
allowExQuant ReadClass
_ = Bool
False

    fullClassName :: ReadClass -> Name
fullClassName ReadClass
Read  = Name
readTypeName
    fullClassName ReadClass
Read1 = Name
read1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
    fullClassName ReadClass
Read2 = Name
read2TypeName
#endif

    classConstraint :: ReadClass -> Int -> Maybe Name
classConstraint ReadClass
rClass Int
i
      | Int
rMin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
rMax = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ReadClass -> Name
forall a. ClassRep a => a -> Name
fullClassName (Int -> ReadClass
forall a. Enum a => Int -> a
toEnum Int
i :: ReadClass)
      | Bool
otherwise              = Maybe Name
forall a. Maybe a
Nothing
      where
        rMin, rMax :: Int
        rMin :: Int
rMin = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum (ReadClass
forall a. Bounded a => a
minBound :: ReadClass)
        rMax :: Int
rMax = ReadClass -> Int
forall a. Enum a => a -> Int
fromEnum ReadClass
rClass

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

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

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

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

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

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

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

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

readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False
                   -> ReadClass
                   -> Name
readPrecOrListName :: Bool -> ReadClass -> Name
readPrecOrListName Bool
False = ReadClass -> Name
readPrecName
readPrecOrListName Bool
True  = ReadClass -> Name
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 :: Bool -> Bool -> ReadClass -> Name
readsOrReadName Bool
False = Bool -> ReadClass -> Name
readsPrecOrListName
readsOrReadName Bool
True  = Bool -> ReadClass -> Name
readPrecOrListName

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

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

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

resultExpr :: Name -> [Exp] -> Q Exp
resultExpr :: Name -> [Exp] -> Q Exp
resultExpr Name
conName [Exp]
as = Name -> Q Exp
varE Name
returnValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
conApp
  where
    conApp :: Q Exp
    conApp :: Q Exp
conApp = [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
as

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

bindLex :: Q Exp -> Q Stmt
bindLex :: Q Exp -> Q Stmt
bindLex Q Exp
pat = Q Exp -> Q Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
expectPValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
pat

identPat :: String -> Q Stmt
identPat :: String -> Q Stmt
identPat String
s = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
identDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
s

symbolPat :: String -> Q Stmt
symbolPat :: String -> Q Stmt
symbolPat String
s = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
symbolDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
s

readPunc :: String -> Q Stmt
readPunc :: String -> Q Stmt
readPunc String
c = Q Exp -> Q Stmt
bindLex (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
puncDataName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE String
c

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

dataConStr :: ConstructorInfo -> String
dataConStr :: ConstructorInfo -> String
dataConStr = Name -> String
nameBase (Name -> String)
-> (ConstructorInfo -> Name) -> ConstructorInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName

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

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

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

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