{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}

-- | Generic implementation of Read
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Data.Internal.Read where

import Data.Coerce
import Data.Functor.Classes (Read1(..))
import Data.Functor.Identity
import Data.Proxy
import Generic.Data.Internal.Utils (isSymDataCon, isSymVar)
import GHC.Generics hiding (prec)
import GHC.Read (expectP, list)
import GHC.Show (appPrec, appPrec1)
import Text.ParserCombinators.ReadPrec
import Text.Read (Read(..), parens)
import Text.Read.Lex (Lexeme(..))

-- | Generic 'readPrec'.
--
-- @
-- instance 'Read' MyType where
--   'readPrec' = 'greadPrec'
--   'readListPrec' = 'readListPrecDefault'
-- @
greadPrec :: (Generic a, GRead0 (Rep a)) => ReadPrec a
greadPrec :: ReadPrec a
greadPrec = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> ReadPrec (Rep a Any) -> ReadPrec a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (ReadPrec Any, ReadPrec [Any]) -> ReadPrec (Rep a Any)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead Proxy (ReadPrec Any, ReadPrec [Any])
forall k (t :: k). Proxy t
Proxy

-- | Generic representation of 'Read' types.
type GRead0 = GRead Proxy

-- | Generic 'liftReadPrec'.
gliftReadPrec
  :: (Generic1 f, GRead1 (Rep1 f))
  => ReadPrec a -> ReadPrec [a]
  -> ReadPrec (f a)
gliftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
gliftReadPrec readPrec' :: ReadPrec a
readPrec' readList' :: ReadPrec [a]
readList' =
  Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f a -> f a) -> ReadPrec (Rep1 f a) -> ReadPrec (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Rep1 f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead ((ReadPrec a, ReadPrec [a]) -> Identity (ReadPrec a, ReadPrec [a])
forall a. a -> Identity a
Identity (ReadPrec a
readPrec', ReadPrec [a]
readList'))

-- | Generic representation of 'Data.Functor.Classes.Read1' types.
type GRead1 = GRead Identity

class GRead p f where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance (GRead p f, IsNullaryDataType f) => GRead p (M1 D d f) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 D d f a)
gPrecRead p :: p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrec (M1 D d f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
parensIfNonNullary (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p))
    where
      x :: f a
      x :: f a
x = f a
forall a. HasCallStack => a
undefined

      parensIfNonNullary :: ReadPrec a -> ReadPrec a
      parensIfNonNullary :: ReadPrec a -> ReadPrec a
parensIfNonNullary = if f Any -> Bool
forall (f :: * -> *) a. IsNullaryDataType f => f a -> Bool
isNullaryDataType f Any
forall a. f a
x
                              then ReadPrec a -> ReadPrec a
forall a. a -> a
id
                              else ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
parens

instance (GRead p f, GRead p g) => GRead p (f :+: g) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:+:) f g a)
gPrecRead p :: p (ReadPrec a, ReadPrec [a])
p = (f a -> (:+:) f g a) -> ReadPrec (f a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p) ReadPrec ((:+:) f g a)
-> ReadPrec ((:+:) f g a) -> ReadPrec ((:+:) f g a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (g a -> (:+:) f g a) -> ReadPrec (g a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GRead p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecRead p (ReadPrec a, ReadPrec [a])
p)

instance (Constructor c, GReadC p c f) => GRead p (M1 C c f) where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 C c f a)
gPrecRead p :: p (ReadPrec a, ReadPrec [a])
p = p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C c f a)
forall (p :: * -> *) (c :: Meta) (f :: * -> *) a.
GReadC p c f =>
p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C c f a)
gPrecReadC p (ReadPrec a, ReadPrec [a])
p (M1 C c f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f Any
forall a. M1 C c f a
x) (M1 C c f Any -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c f Any
forall a. M1 C c f a
x)
    where
      x :: M1 C c f a
      x :: M1 C c f a
x = M1 C c f a
forall a. HasCallStack => a
undefined

instance GRead p V1 where
  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (V1 a)
gPrecRead _ = ReadPrec (V1 a)
forall a. ReadPrec a
pfail

class IsNullaryDataType f where
  isNullaryDataType :: f a -> Bool

instance IsNullaryDataType (f :+: g) where
  isNullaryDataType :: (:+:) f g a -> Bool
isNullaryDataType _ = Bool
False

instance IsNullaryDataType (C1 c f) where
  isNullaryDataType :: C1 c f a -> Bool
isNullaryDataType _ = Bool
False

instance IsNullaryDataType V1 where
  isNullaryDataType :: V1 a -> Bool
isNullaryDataType _ = Bool
True

class GReadC p c f where
  gPrecReadC :: p (ReadPrec a, ReadPrec [a]) -> String -> Fixity -> ReadPrec (M1 C c f a)

instance GReadFields p f => GReadC p ('MetaCons s y 'False) f where
  gPrecReadC :: forall a. p (ReadPrec a, ReadPrec [a]) -> String -> Fixity
             -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
  gPrecReadC :: p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
gPrecReadC p :: p (ReadPrec a, ReadPrec [a])
p name :: String
name fixity :: Fixity
fixity
    | Infix _ fy :: Int
fy <- Fixity
fixity, Branch k1 :: ReadPrecTree (f a)
k1 k2 :: ReadPrecTree (g a)
k2 <- ReadPrecTree (f a)
fields
    = ReadPrec ((:*:) f g a)
-> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec ((:*:) f g a)
 -> ReadPrec (M1 C ('MetaCons s y 'False) f a))
-> ReadPrec ((:*:) f g a)
-> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
fy (ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a))
-> ReadPrec ((:*:) f g a) -> ReadPrec ((:*:) f g a)
forall a b. (a -> b) -> a -> b
$ do
        f a
k1' <- ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
k1
        if String -> Bool
isSymDataCon String
name
           then Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
name)
           else (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP ([String -> Lexeme
Punc "`"] [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ String -> [Lexeme]
identHLexemes String
name [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ [String -> Lexeme
Punc "`"])
        g a
k2' <- ReadPrecTree (g a) -> ReadPrec (g a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (g a)
k2
        (:*:) f g a -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
k1' f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
k2')
    | Bool
otherwise
    = ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a))
-> ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'False) f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (f a) -> ReadPrec (f a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
appPrec (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ do
        String -> ReadPrec ()
readPrefixCon String
name
        ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
fields
    where
      fields :: ReadPrecTree (f a)
      fields :: ReadPrecTree (f a)
fields = p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p

instance GReadNamed p f => GReadC p ('MetaCons s y 'True) f where
  gPrecReadC :: p (ReadPrec a, ReadPrec [a])
-> String -> Fixity -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
gPrecReadC p :: p (ReadPrec a, ReadPrec [a])
p name :: String
name _fixity :: Fixity
_fixity = ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a))
-> ReadPrec (f a) -> ReadPrec (M1 C ('MetaCons s y 'True) f a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (f a) -> ReadPrec (f a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
appPrec1 (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ do
    String -> ReadPrec ()
readPrefixCon String
name
    Char -> ReadPrec (f a) -> Char -> ReadPrec (f a)
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround '{' ReadPrec (f a)
fields '}'
    where
      fields :: ReadPrec (f a)
fields = p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p

class GReadFields p f where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)

instance (GReadFields p f, GReadFields p g) => GReadFields p (f :*: g) where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree ((:*:) f g a)
gPrecReadFields p :: p (ReadPrec a, ReadPrec [a])
p = ReadPrecTree (f a)
-> ReadPrecTree (g a) -> ReadPrecTree ((:*:) f g a)
forall (i :: * -> *) c (g :: * -> *).
ReadPrecTree (i c)
-> ReadPrecTree (g c) -> ReadPrecTree ((:*:) i g c)
Branch (p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p) (p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadFields p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)
gPrecReadFields p (ReadPrec a, ReadPrec [a])
p)

instance GReadSingle p f => GReadFields p (M1 S c f) where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (M1 S c f a)
gPrecReadFields p :: p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrecTree (M1 S c f a)
forall (f :: * -> *) a i (c :: Meta).
ReadPrec (f a) -> ReadPrecTree (M1 i c f a)
M1Leaf (ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
step (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p))

instance GReadFields p U1 where
  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (U1 a)
gPrecReadFields _ = ReadPrecTree (U1 a)
forall a. ReadPrecTree (U1 a)
U1Leaf

class GReadNamed p f where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance (GReadNamed p f, GReadNamed p g) => GReadNamed p (f :*: g) where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:*:) f g a)
gPrecReadNamed p :: p (ReadPrec a, ReadPrec [a])
p = do
    f a
l <- p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p
    Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc ",")
    g a
r <- p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadNamed p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadNamed p (ReadPrec a, ReadPrec [a])
p
    (:*:) f g a -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
l f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
r)

instance (Selector c, GReadSingle p f) => GReadNamed p (M1 S c f) where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (M1 S c f a)
gPrecReadNamed p :: p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f a) -> ReadPrec (M1 S c f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (M1 S c f a))
-> ReadPrec (f a) -> ReadPrec (M1 S c f a)
forall a b. (a -> b) -> a -> b
$ do
    (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP [Lexeme]
snameLexemes
    Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc "=")
    ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
reset (p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p)
    where
      x :: M1 S c f a
      x :: M1 S c f a
x = M1 S c f a
forall a. HasCallStack => a
undefined

      sname :: String
      sname :: String
sname = M1 S c f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S c f Any
forall a. M1 S c f a
x

      snameLexemes :: [Lexeme]
      snameLexemes :: [Lexeme]
snameLexemes | String -> Bool
isSymVar String
sname
                   = [String -> Lexeme
Punc "(", String -> Lexeme
Symbol String
sname, String -> Lexeme
Punc ")"]
                   | Bool
otherwise
                   = String -> [Lexeme]
identHLexemes String
sname

instance GReadNamed p U1 where
  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (U1 a)
gPrecReadNamed _ = U1 a -> ReadPrec (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1

class GReadSingle p f where
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)

instance Read a => GReadSingle p (K1 i a) where
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (K1 i a a)
gPrecReadSingle _ = ReadPrec a -> ReadPrec (K1 i a a)
forall x. ReadPrec a -> ReadPrec (K1 i a x)
coerceK1 ReadPrec a
forall a. Read a => ReadPrec a
readPrec
    where
      coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x)
      coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x)
coerceK1 = ReadPrec a -> ReadPrec (K1 i a x)
forall a b. Coercible a b => a -> b
coerce

instance Read1 f => GReadSingle Identity (Rec1 f) where
  gPrecReadSingle :: Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Rec1 f a)
gPrecReadSingle (Identity p :: (ReadPrec a, ReadPrec [a])
p) = ReadPrec (f a) -> ReadPrec (Rec1 f a)
forall a. ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 ((ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
forall (f :: * -> *) a.
Read1 f =>
(ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (ReadPrec a, ReadPrec [a])
p)
    where
      coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
      coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 = ReadPrec (f a) -> ReadPrec (Rec1 f a)
forall a b. Coercible a b => a -> b
coerce

instance GReadSingle Identity Par1 where
  gPrecReadSingle :: Identity (ReadPrec a, ReadPrec [a]) -> ReadPrec (Par1 a)
gPrecReadSingle (Identity (readPrec' :: ReadPrec a
readPrec', _)) = ReadPrec a -> ReadPrec (Par1 a)
forall p. ReadPrec p -> ReadPrec (Par1 p)
coercePar1 ReadPrec a
readPrec'
    where
      coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
      coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
coercePar1 = ReadPrec p -> ReadPrec (Par1 p)
forall a b. Coercible a b => a -> b
coerce

instance (Read1 f, GReadSingle p g) => GReadSingle p (f :.: g) where
  gPrecReadSingle :: forall a. p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((f :.: g) a)
  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((:.:) f g a)
gPrecReadSingle p :: p (ReadPrec a, ReadPrec [a])
p = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 ((ReadPrec (g a), ReadPrec [g a]) -> ReadPrec (f (g a))
forall (f :: * -> *) a.
Read1 f =>
(ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (ReadPrec (g a)
readPrec_, ReadPrec [g a]
readList_))
    where
      readPrec_ :: ReadPrec (g a)
      readPrec_ :: ReadPrec (g a)
readPrec_ = p (ReadPrec a, ReadPrec [a]) -> ReadPrec (g a)
forall (p :: * -> *) (f :: * -> *) a.
GReadSingle p f =>
p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
gPrecReadSingle p (ReadPrec a, ReadPrec [a])
p

      readList_ :: ReadPrec [g a]
      readList_ :: ReadPrec [g a]
readList_ = ReadPrec (g a) -> ReadPrec [g a]
forall a. ReadPrec a -> ReadPrec [a]
list ReadPrec (g a)
readPrec_

      coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a)
      coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
forall a b. Coercible a b => a -> b
coerce

-- Helpers

coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 = ReadPrec (f p) -> ReadPrec (M1 i c f p)
forall a b. Coercible a b => a -> b
coerce

-- | A backwards-compatible version of 'liftReadPrec'. This is needed for
-- compatibility with @base-4.9@, where 'Read1' only offers 'liftReadsPrec',
-- not 'liftReadPrec'.
liftReadPrecCompat :: Read1 f => (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat :: (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)
liftReadPrecCompat (readPrec' :: ReadPrec a
readPrec', readList' :: ReadPrec [a]
readList') =
#if MIN_VERSION_base(4,10,0)
    ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec a
readPrec' ReadPrec [a]
readList'
#else
    readS_to_Prec (liftReadsPrec (readPrec_to_S readPrec')
                                 (readPrec_to_S readList' 0))
#endif

data ReadPrecTree a where
  U1Leaf :: ReadPrecTree (U1 a)
  M1Leaf :: ReadPrec (f a) -> ReadPrecTree (M1 i c f a)
  Branch :: ReadPrecTree (f a) -> ReadPrecTree (g a) -> ReadPrecTree ((f :*: g) a)

toReadPrec :: ReadPrecTree a -> ReadPrec a
toReadPrec :: ReadPrecTree a -> ReadPrec a
toReadPrec U1Leaf       = U1 a -> ReadPrec (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
toReadPrec (M1Leaf f :: ReadPrec (f a)
f)   = ReadPrec (f a) -> ReadPrec (M1 i c f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 ReadPrec (f a)
f
toReadPrec (Branch f :: ReadPrecTree (f a)
f g :: ReadPrecTree (g a)
g) = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> ReadPrec (f a) -> ReadPrec (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrecTree (f a) -> ReadPrec (f a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (f a)
f ReadPrec (g a -> (:*:) f g a)
-> ReadPrec (g a) -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadPrecTree (g a) -> ReadPrec (g a)
forall a. ReadPrecTree a -> ReadPrec a
toReadPrec ReadPrecTree (g a)
g

identHLexemes :: String -> [Lexeme]
identHLexemes :: String -> [Lexeme]
identHLexemes s :: String
s | Just (ss :: String
ss, '#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Lexeme
Ident String
ss, String -> Lexeme
Symbol "#"]
                | Bool
otherwise                    = [String -> Lexeme
Ident String
s]

readPrefixCon :: String -> ReadPrec ()
readPrefixCon :: String -> ReadPrec ()
readPrefixCon name :: String
name
  | String -> Bool
isSymDataCon String
name
  = Char -> ReadPrec () -> Char -> ReadPrec ()
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround '(' (Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
name)) ')'
  | Bool
otherwise
  = (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP (String -> [Lexeme]
identHLexemes String
name)

readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround c1 :: Char
c1 r :: ReadPrec a
r c2 :: Char
c2 = do
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c1])
  a
r' <- ReadPrec a
r
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c2])
  a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r'

-- Split off the last element.
snocView :: [a] -> Maybe ([a], a)
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"