{-# 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 = 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 = 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 = 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 = 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 rClass :: ReadClass
rClass opts :: ReadOptions
opts name :: 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
      (instanceCxt :: Cxt
instanceCxt, instanceType :: 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 rClass :: ReadClass
rClass opts :: ReadOptions
opts instTypes :: Cxt
instTypes cons :: [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 rClass :: ReadClass
rClass urp :: Bool
urp name :: 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 rClass :: ReadClass
rClass urp :: Bool
urp instTypes :: Cxt
instTypes cons :: [ConstructorInfo]
cons = do
    Name
p   <- String -> Q Name
newName "p"
    [Name]
rps <- String -> Int -> Q [Name]
newNameList "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 "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 (\x :: Name
x (y :: Name
y, z :: Name
z) -> (Name
x, Name -> Name -> OneOrTwoNames Two
TwoNames Name
y Name
z)) [Name]
lastTyVars [(Name, Name)]
rpls

    let nullaryCons, nonNullaryCons :: [ConstructorInfo]
        (nullaryCons :: [ConstructorInfo]
nullaryCons, nonNullaryCons :: [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
          [] -> []
          [con :: ConstructorInfo
con]
            | Name -> String
nameBase (ConstructorInfo -> Name
constructorName ConstructorInfo
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "()"
           -> [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) [])]
          _ -> [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 e1 :: Q Exp
e1 e2 :: 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 con :: 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 con :: 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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: 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 "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
    (readStmts :: [Q Stmt]
readStmts, varExps :: [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 ",") [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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                   , constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
ctxt
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor argNames :: [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 "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'
    (readStmts :: [[Q Stmt]]
readStmts, varExps :: [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
        (\argName :: Name
argName argTy :: Type
argTy arg :: 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 "{"]
                      [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 ","] [[Q Stmt]]
readStmts)
                      [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++ [String -> Q Stmt
readPunc "}"]

    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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: 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
    [alTy :: Type
alTy, arTy :: 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 "argL"
    Name
ar <- String -> Q Name
newName "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
    ([readStmt1 :: Q Stmt
readStmt1, readStmt2 :: Q Stmt
readStmt2], varExps :: [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 prec :: Int
prec _ -> 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 "`"] [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 "`"]
        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 rClass :: ReadClass
rClass isTup :: Bool
isTup urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName ty :: Type
ty tyExpName :: Name
tyExpName = do
    (rExp :: Exp
rExp, varExp :: 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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName lblStr :: String
lblStr ty :: Type
ty tyExpName :: Name
tyExpName = do
    (rExp :: Exp
rExp, varExp :: 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 readFieldName :: Name
readFieldName lbl :: 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 (ss :: String
ss, '#') <- 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 _ urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap _ tyExpName :: Name
tyExpName rl :: Bool
rl (VarT tyName :: 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 rpExp :: Name
rpExp rlExp :: 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)
      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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl (SigT ty :: 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
makeReadForType rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl (ForallT _ _ ty :: 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 rClass :: ReadClass
rClass urp :: Bool
urp tvMap :: Map Name (OneOrTwoNames Two)
tvMap conName :: Name
conName tyExpName :: Name
tyExpName rl :: Bool
rl ty :: Type
ty = do
    let tyCon :: Type
        tyArgs :: [Type]
        tyCon :: Type
tyCon:tyArgs :: Cxt
tyArgs = 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]
        (lhsArgs :: Cxt
lhsArgs, rhsArgs :: 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 <- Type -> Q Bool
isTyFamily Type
tyCon
    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 (\b :: 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 _ = Bool
False

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

    classConstraint :: ReadClass -> Int -> Maybe Name
classConstraint rClass :: ReadClass
rClass i :: 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 Read  = Name
readsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
readsPrecConstName Read1 = Name
liftReadsPrecConstValName
readsPrecConstName Read2 = Name
liftReadsPrec2ConstValName
#else
readsPrecConstName Read1 = readsPrec1ConstValName
#endif

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

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

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

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

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

readListName :: ReadClass -> Name
readListName :: ReadClass -> Name
readListName Read  = Name
readListValName
#if defined(NEW_FUNCTOR_CLASSES)
readListName Read1 = Name
liftReadListValName
readListName 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 False = ReadClass -> Name
readsPrecName
readsPrecOrListName True  = ReadClass -> Name
readListName

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

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

mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp
mkParser p :: Int
p ss :: [Q Stmt]
ss b :: 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 ss :: [Q Stmt]
ss b :: 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 conName :: Name
conName as :: [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 s :: String
s
    | Just (ss :: String
ss, '#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Q Stmt
identPat String
ss, String -> Q Stmt
symbolPat "#"]
    | Bool
otherwise                    = [String -> Q Stmt
identPat String
s]

bindLex :: Q Exp -> Q Stmt
bindLex :: Q Exp -> Q Stmt
bindLex pat :: 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 s :: 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 s :: 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 c :: 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 xs :: [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 acc :: [a]
acc [a :: 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 acc :: [a]
acc (a :: a
a:as :: [a]
as) = [a] -> [a] -> Maybe ([a], a)
go (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
as
    go _   []     = String -> Maybe ([a], a)
forall a. HasCallStack => String -> a
error "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 conStr :: String
conStr
  | String -> Bool
isSym String
conStr = [String -> Q Stmt
readPunc "(", String -> Q Stmt
symbolPat String
conStr, String -> Q Stmt
readPunc ")"]
  | Bool
otherwise    = String -> [Q Stmt]
identHPat String
conStr

wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS :: Bool -> Q Exp -> Q Exp
wrapReadS urp :: Bool
urp e :: 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 rClass :: ReadClass
rClass opts :: 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
        Read  -> Bool
True
        Read1 -> Bool
base4'10OrLater
#if defined(NEW_FUNCTOR_CLASSES)
        Read2 -> Bool
base4'10OrLater
#endif