{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE NoOverloadedLists #-}

-- |
-- Module: M.PkMacro
-- Description: Template Haskell generator for data types with 'Pack'\/'Unpack' instances
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- This module provides Template Haskell functionality to generate data types with
-- automatic 'Pack'\/'Unpack' instances. It uses a simple grammar to define data types
-- and their field mappings.
--
-- == Usage
--
-- Define data types using the 'pkmacro' quasi-quoter. The syntax is indentation-insensitive:
--
-- @
-- -- First, set up default instances
-- 'setdefaultderives'  -- Sets up 'Generic', 'Pack', and 'Unpack' derives
--
-- -- Define a newtype wrapper with 'Pack'\/'Unpack' instances
-- newtype AAA = AAA 'Data.Int.Int32'
--   deriving stock ('Generic')
--   deriving newtype ('Pack', 'Unpack')
--
-- [pkmacro|
-- -- Regular data type with two fields
-- data A {
--   f1 :: Int32,                -- Regular field
--   f2 :: Int32 via AAA,       -- Field with custom serialization
-- }
--
-- -- Data type with one field and explicit deriving
-- data B {
--   f3 :: Int32,
--   deriving ('Generic', 'Show')
-- }
--
-- -- Empty data type (creates constructor with no fields)
-- data C {}
-- |]
-- @
--
-- The grammar supports:
--
-- * Empty data types (no fields)
-- * Custom serialization via @via@ clause
-- * Multiple data types in one block
-- * Indentation-insensitive syntax
-- * Comments (both @--@ and @{- -}@ style)
--
-- == Syntax
--
-- The full syntax for data type definitions is:
--
-- @
-- data TypeName {
--   field1 :: Type1 [via Type2],     -- Field with optional via clause
--   field2 :: Type3,                 -- Regular field
--   [deriving (Class1, Class2)]      -- Optional proper deriving clause
--   [and shadow deriving ('Pack', 'Unpack') with (Class3, Class4)] -- Optional shadow deriving
-- }
-- @
--
-- Elements in square brackets are optional.
--
-- * The @via@ clause specifies a different type to use for serialization
-- * @deriving@ adds instances to the main data type
-- * @shadow deriving@ adds instances to the generated shadow type used for serialization
-- * Multiple data types can be defined in a single quasi-quoter block
--
-- === Type Syntax
--
-- Types can include:
--
-- * Simple types: @'Data.Int.Int32'@, @'Data.Text.Text'@, etc.
-- * Parameterized types: @'Maybe' a@, @['Int']@
-- * Type applications: @a \@k@
-- * Promoted types: @\'True@, @\'Just@
-- * Type literals: @\"hello\"@, @123@
-- * Parenthesized types: @(a, b)@, @('Either' a b)@
--
-- See: 'Pack', 'Unpack', 'setdefaultderives', 'addproperderives', and 'addshadowderives'.
module M.PkMacro
  ( setdefaultderives,
    addproperderives,
    addshadowderives,
    pkmacro,
  )
where

import Control.Applicative.Combinators hiding (optional, (<|>))
import Control.Category ((>>>))
import Control.Monad
import Data.ByteString qualified as B
import Data.Char hiding (isDigit)
import Data.Coerce
import Data.Foldable1
import Data.Function
import Data.Functor
import Data.List ((\\))
import Data.List.NonEmpty qualified as NEL
import Data.Maybe
import Data.Typeable
import FlatParse.Stateful hiding (Parser, Result)
import GHC.Generics
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import M.Pack

-- data A {
--  field1 :: Type via Type,
--  field2 :: Type,
--  deriving (Classes 1)
--    and shadow deriving (Pack, Unpack)
--    with (Classes 2)
-- }

type P a = forall st r. Parser st r a

noop :: (Applicative m) => m ()
noop :: forall (m :: * -> *). Applicative m => m ()
noop = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Skip whitespace and comments
ws :: P ()
ws :: P ()
ws =
  $( switch
       [|
         case _ of
           " " -> ws
           "\n" -> ws
           "\t" -> ws
           "\r" -> ws
           "--" -> linecomment
           "{-" -> multilinecomment
           _ -> noop
         |]
   )

typeident, typeident' :: P String
typeident :: P String
typeident = (Char -> String -> String)
-> ParserT st r ParseError Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall a b c.
(a -> b -> c)
-> ParserT st r ParseError a
-> ParserT st r ParseError b
-> ParserT st r ParseError c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ((Char -> Bool) -> ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
goh Char -> Bool
chh) ((Char -> Bool) -> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e String
got Char -> Bool
cht)
  where
    goh :: (Char -> Bool) -> ParserT st r e Char
goh = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii
    got :: (Char -> Bool) -> ParserT st r e String
got = ParserT st r e Char -> ParserT st r e String
forall a. ParserT st r e a -> ParserT st r e [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParserT st r e Char -> ParserT st r e String)
-> ((Char -> Bool) -> ParserT st r e Char)
-> (Char -> Bool)
-> ParserT st r e String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii
    chh :: Char -> Bool
chh Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
c) Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
    cht :: Char -> Bool
cht Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
typeident' :: P String
typeident' = ParserT st r ParseError String
-> ParseError -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut ParserT st r ParseError String
P String
typeident ParseError
"expected a type identifier"

fieldident :: P String
fieldident :: P String
fieldident = (Char -> String -> String)
-> ParserT st r ParseError Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall a b c.
(a -> b -> c)
-> ParserT st r ParseError a
-> ParserT st r ParseError b
-> ParserT st r ParseError c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ((Char -> Bool) -> ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
goh Char -> Bool
chh) ((Char -> Bool) -> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e String
got Char -> Bool
cht)
  where
    goh :: (Char -> Bool) -> ParserT st r e Char
goh = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii
    got :: (Char -> Bool) -> ParserT st r e String
got = ParserT st r e Char -> ParserT st r e String
forall a. ParserT st r e a -> ParserT st r e [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParserT st r e Char -> ParserT st r e String)
-> ((Char -> Bool) -> ParserT st r e Char)
-> (Char -> Bool)
-> ParserT st r e String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii
    chh :: Char -> Bool
chh Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
c) Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
    cht :: Char -> Bool
cht Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

linecomment :: P ()
linecomment :: P ()
linecomment = ParserT st r ParseError Word8
-> (Word8 -> ParserT st r ParseError ())
-> ParserT st r ParseError ()
-> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e a ret.
ParserT st r e a
-> (a -> ParserT st r e ret)
-> ParserT st r e ret
-> ParserT st r e ret
withOption ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
anyWord8 (\case Word8
10 -> ParserT st r ParseError ()
P ()
ws; Word8
_ -> ParserT st r ParseError ()
P ()
linecomment) ParserT st r ParseError ()
forall (m :: * -> *). Applicative m => m ()
noop

multilinecomment :: P ()
multilinecomment :: P ()
multilinecomment =
  (Int
1 :: Int) Int -> (Int -> Parser st r ()) -> Parser st r ()
forall a b. a -> (a -> b) -> b
& ((Int -> Parser st r ()) -> Int -> Parser st r ())
-> Int -> Parser st r ()
forall a. (a -> a) -> a
fix \Int -> Parser st r ()
f -> \case
    Int
0 -> Parser st r ()
P ()
ws
    Int
n ->
      $( switch
           [|
             case _ of
               "-}" -> f (n - 1)
               "{-" -> f (n + 1)
               _ -> branch anyWord8 (f n) noop
             |]
       )

data DataDecl = DataDecl
  { DataDecl -> Name
dataname :: TH.Name,
    DataDecl -> [Field]
dataflds :: [Field],
    DataDecl -> [Type]
dataderp :: [TH.Type], -- proper
    DataDecl -> [Type]
dataders :: [TH.Type] -- shadow
  }
  deriving (Int -> DataDecl -> String -> String
[DataDecl] -> String -> String
DataDecl -> String
(Int -> DataDecl -> String -> String)
-> (DataDecl -> String)
-> ([DataDecl] -> String -> String)
-> Show DataDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DataDecl -> String -> String
showsPrec :: Int -> DataDecl -> String -> String
$cshow :: DataDecl -> String
show :: DataDecl -> String
$cshowList :: [DataDecl] -> String -> String
showList :: [DataDecl] -> String -> String
Show)

data Field = Field
  { Field -> Name
fieldname :: TH.Name,
    Field -> FieldType
fieldtype :: FieldType
  }
  deriving (Int -> Field -> String -> String
[Field] -> String -> String
Field -> String
(Int -> Field -> String -> String)
-> (Field -> String) -> ([Field] -> String -> String) -> Show Field
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Field -> String -> String
showsPrec :: Int -> Field -> String -> String
$cshow :: Field -> String
show :: Field -> String
$cshowList :: [Field] -> String -> String
showList :: [Field] -> String -> String
Show)

data FieldType = FieldType
  { FieldType -> Type
typemain :: TH.Type,
    FieldType -> Maybe Type
typevia :: Maybe TH.Type
  }
  deriving (Int -> FieldType -> String -> String
[FieldType] -> String -> String
FieldType -> String
(Int -> FieldType -> String -> String)
-> (FieldType -> String)
-> ([FieldType] -> String -> String)
-> Show FieldType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FieldType -> String -> String
showsPrec :: Int -> FieldType -> String -> String
$cshow :: FieldType -> String
show :: FieldType -> String
$cshowList :: [FieldType] -> String -> String
showList :: [FieldType] -> String -> String
Show)

data ShadowDir = ViaShadow | ViaMain
  deriving (Int -> ShadowDir -> String -> String
[ShadowDir] -> String -> String
ShadowDir -> String
(Int -> ShadowDir -> String -> String)
-> (ShadowDir -> String)
-> ([ShadowDir] -> String -> String)
-> Show ShadowDir
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ShadowDir -> String -> String
showsPrec :: Int -> ShadowDir -> String -> String
$cshow :: ShadowDir -> String
show :: ShadowDir -> String
$cshowList :: [ShadowDir] -> String -> String
showList :: [ShadowDir] -> String -> String
Show, ShadowDir -> ShadowDir -> Bool
(ShadowDir -> ShadowDir -> Bool)
-> (ShadowDir -> ShadowDir -> Bool) -> Eq ShadowDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShadowDir -> ShadowDir -> Bool
== :: ShadowDir -> ShadowDir -> Bool
$c/= :: ShadowDir -> ShadowDir -> Bool
/= :: ShadowDir -> ShadowDir -> Bool
Eq)

-- used in datadecl
hasktype :: P String
hasktype :: P String
hasktype = Parser st r ()
P ()
ws Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParserT st r ParseError String
P String
typeexpr ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
ws)
  where
    typeexpr :: ParserT st r ParseError String
typeexpr = do
      [String] -> String
unwords ([String] -> String)
-> ParserT st r ParseError [String]
-> ParserT st r ParseError String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        (:)
          (String -> [String] -> [String])
-> ParserT st r ParseError String
-> ParserT st r ParseError ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser st r ()
P ()
ws Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> ParserT st r ParseError String
typecomponent Bool
False ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
ws)
          ParserT st r ParseError ([String] -> [String])
-> ParserT st r ParseError [String]
-> ParserT st r ParseError [String]
forall a b.
ParserT st r ParseError (a -> b)
-> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParserT st r ParseError String -> ParserT st r ParseError [String]
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> ParserT st r ParseError String
typecomponent Bool
True ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
ws)
    surround :: a -> a -> [a] -> [a]
surround a
c a
d = (a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d)
    typecomponent :: Bool -> ParserT st r ParseError String
typecomponent Bool
tailpos = do
      let bracketed :: ParserT st r ParseError a
-> ParserT st r ParseError b
-> a
-> a
-> ParserT st r ParseError [a]
-> ParserT st r ParseError [a]
bracketed ParserT st r ParseError a
c ParserT st r ParseError b
d a
c' a
d' ParserT st r ParseError [a]
p = ParserT st r ParseError a
c ParserT st r ParseError a
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError [a] -> ParserT st r ParseError [a]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([a] -> [a])
-> ParserT st r ParseError [a] -> ParserT st r ParseError [a]
forall a b.
(a -> b) -> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> a -> [a] -> [a]
forall {a}. a -> a -> [a] -> [a]
surround a
c' a
d') ParserT st r ParseError [a]
p ParserT st r ParseError [a]
-> ParserT st r ParseError b -> ParserT st r ParseError [a]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError b
d
      Parser st r () -> Parser st r ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a
lookahead (Parser st r () -> Parser st r ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e ()
fails $(string "via")) Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
        ParserT st r ParseError String
P String
typeident
          ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (Bool -> Parser st r ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
tailpos Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError String
P String
fieldident)
          ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> ( $(char '@')
                  Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> String)
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
(a -> b) -> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    (Char
'@' Char -> String -> String
forall a. a -> [a] -> [a]
:)
                    ( (Integer -> String)
-> ParserT st r ParseError Integer
-> ParserT st r ParseError String
forall a b.
(a -> b) -> ParserT st r ParseError a -> ParserT st r ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> String
forall a. Show a => a -> String
show ParserT st r ParseError Integer
forall (st :: ZeroBitType) r e. ParserT st r e Integer
anyAsciiDecimalInteger
                        ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> ParserT st r ParseError String
P String
typeident
                        ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> ParserT st r ParseError String
P String
fieldident
                        ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser st r ()
-> Parser st r ()
-> Char
-> Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {a} {b} {a}.
ParserT st r ParseError a
-> ParserT st r ParseError b
-> a
-> a
-> ParserT st r ParseError [a]
-> ParserT st r ParseError [a]
bracketed $(char '(') $(char ')') Char
'(' Char
')' ParserT st r ParseError String
P String
hasktype
                        ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser st r ()
-> Parser st r ()
-> Char
-> Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {a} {b} {a}.
ParserT st r ParseError a
-> ParserT st r ParseError b
-> a
-> a
-> ParserT st r ParseError [a]
-> ParserT st r ParseError [a]
bracketed $(char '[') $(char ']') Char
'[' Char
']' ParserT st r ParseError String
P String
hasktype
                    )
              )
          ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser st r ()
-> Parser st r ()
-> Char
-> Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {a} {b} {a}.
ParserT st r ParseError a
-> ParserT st r ParseError b
-> a
-> a
-> ParserT st r ParseError [a]
-> ParserT st r ParseError [a]
bracketed $(char '(') $(char ')') Char
'(' Char
')' ParserT st r ParseError String
typeexpr
          ParserT st r ParseError String
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser st r ()
-> Parser st r ()
-> Char
-> Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall {st :: ZeroBitType} {r} {a} {b} {a}.
ParserT st r ParseError a
-> ParserT st r ParseError b
-> a
-> a
-> ParserT st r ParseError [a]
-> ParserT st r ParseError [a]
bracketed $(char '[') $(char ']') Char
'[' Char
']' ParserT st r ParseError String
typeexpr

ewrap :: Parser st r a -> Parser st r a
ewrap :: forall (st :: ZeroBitType) r a. Parser st r a -> Parser st r a
ewrap = (Parser st r a -> (ParseError -> Parser st r a) -> Parser st r a)
-> (ParseError -> Parser st r a) -> Parser st r a -> Parser st r a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser st r a -> (ParseError -> Parser st r a) -> Parser st r a
forall (st :: ZeroBitType) r e b.
ParserT st r e b -> (e -> ParserT st r e b) -> ParserT st r e b
withError \ParseError
e -> do
  r <- ParserT st r ParseError ByteString
-> ParserT st r ParseError ByteString
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a
lookahead ParserT st r ParseError ByteString
forall (st :: ZeroBitType) r e. ParserT st r e ByteString
takeRest
  let r' = if ByteString -> Int
B.length ByteString
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall {a}. Num a => a
le then ByteString -> ByteString -> ByteString
B.append (Int -> ByteString -> ByteString
B.take Int
forall {a}. Num a => a
le ByteString
r) ByteString
"..." else ByteString
r
      le = a
36
  err $ e <> (ParseError $ ", the rest being " ++ show r')

datadecl :: P DataDecl
datadecl :: P DataDecl
datadecl = do
  let data' :: ParserT st r e ()
data' = $(string "data")
      openb :: Parser st r ()
openb = Parser st r () -> Parser st r ()
forall (st :: ZeroBitType) r a. Parser st r a -> Parser st r a
ewrap (Parser st r () -> Parser st r ())
-> Parser st r () -> Parser st r ()
forall a b. (a -> b) -> a -> b
$ Parser st r () -> ParseError -> Parser st r ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut $(char '{') ParseError
"expecting '{'"
      closb :: Parser st r ()
closb = Parser st r () -> Parser st r ()
forall (st :: ZeroBitType) r a. Parser st r a -> Parser st r a
ewrap (Parser st r () -> Parser st r ())
-> Parser st r () -> Parser st r ()
forall a b. (a -> b) -> a -> b
$ Parser st r () -> ParseError -> Parser st r ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut $(char '}') ParseError
"expecting '}'"
      deriv :: ParserT st r e ()
deriv = $(string "deriving")
      comma :: ParserT st r ParseError ()
comma = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char ',') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
      shado :: ParserT st r ParseError ()
shado = do
        do $(string "and") ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(string "shadow") ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
        do $(string "deriving") ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '(') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(string "Pack")
        do ParserT st r ParseError ()
P ()
comma ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(string "Unpack") ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char ')') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
        do $(string "with")
      doubc :: Parser st r ()
doubc = Parser st r () -> Parser st r ()
forall (st :: ZeroBitType) r a. Parser st r a -> Parser st r a
ewrap (Parser st r () -> Parser st r ())
-> Parser st r () -> Parser st r ()
forall a b. (a -> b) -> a -> b
$ Parser st r () -> ParseError -> Parser st r ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut $(string "::") ParseError
"expecting '::'"
      parsety :: ParserT st r ParseError Type
parsety =
        Parser st r String
P String
hasktype Parser st r String
-> (String -> ParserT st r ParseError Type)
-> ParserT st r ParseError Type
forall a b.
ParserT st r ParseError a
-> (a -> ParserT st r ParseError b) -> ParserT st r ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= do
          String -> ByteString
strToUtf8 (String -> ByteString)
-> (ByteString -> ParserT st r ParseError Type)
-> String
-> ParserT st r ParseError Type
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (st :: ZeroBitType). Parser st () Type)
-> ByteString -> Result Type
forall a.
(forall (st :: ZeroBitType). Parser st () a)
-> ByteString -> Result a
parsepure0 (Parser st () Type
P Type
thhasktype Parser st () Type
-> ParserT st () ParseError () -> Parser st () Type
forall a b.
ParserT st () ParseError a
-> ParserT st () ParseError b -> ParserT st () ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st () ParseError ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
eof) (ByteString -> Result Type)
-> (Result Type -> ParserT st r ParseError Type)
-> ByteString
-> ParserT st r ParseError Type
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
            OK Type
v Int
_ ByteString
_ -> Type -> ParserT st r ParseError Type
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
v
            Result Type
Fail -> ParserT st r ParseError Type
forall a. ParserT st r ParseError a
forall (f :: * -> *) a. Alternative f => f a
empty
            Err ParseError
e -> ParseError -> ParserT st r ParseError Type
forall e (st :: ZeroBitType) r a. e -> ParserT st r e a
err ParseError
e
  dataname <-
    String -> Name
TH.mkName (String -> Name)
-> ParserT st r ParseError String -> ParserT st r ParseError Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Parser st r ()
P ()
ws Parser st r () -> Parser st r () -> Parser st r ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser st r ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
data' Parser st r () -> Parser st r () -> Parser st r ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser st r ()
P ()
ws Parser st r ()
-> ParserT st r ParseError String -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError String
P String
typeident' ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
ws ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
openb ParserT st r ParseError String
-> Parser st r () -> ParserT st r ParseError String
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
P ()
ws
  dataflds <- flip endBy comma do
    ws *> fails $(string "deriving") *> do
      fn <- TH.mkName <$> (fieldident <* ws <* doubc <* ws)
      ty <- parsety
      vi <- optional ($(string "via") *> ws *> parsety <* ws)
      pure $ Field fn (FieldType ty vi)
  let parsetypes =
        let t :: ParserT st r ParseError [Type]
t = ParserT st r ParseError Type
-> ParserT st r ParseError () -> ParserT st r ParseError [Type]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy ParserT st r ParseError Type
P Type
parsety ParserT st r ParseError ()
P ()
comma
         in ParserT st r ParseError [Type]
-> ParseError -> ParserT st r ParseError [Type]
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut
              ((ParserT st r ParseError ()
-> ParserT st r ParseError ()
-> ParserT st r ParseError [Type]
-> ParserT st r ParseError [Type]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between $(char '(') $(char ')') ParserT st r ParseError [Type]
forall {st :: ZeroBitType} {r}. ParserT st r ParseError [Type]
t ParserT st r ParseError [Type]
-> ParserT st r ParseError [Type] -> ParserT st r ParseError [Type]
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> ParserT st r ParseError [Type]
forall {st :: ZeroBitType} {r}. ParserT st r ParseError [Type]
t) ParserT st r ParseError [Type]
-> ParserT st r ParseError () -> ParserT st r ParseError [Type]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws)
              ParseError
"expecting type; types"
  ws
  dataderp <- option [] do deriv *> ws *> parsetypes
  dataders <- option [] do shado *> ws *> parsetypes
  DataDecl {..} <$ closb <* ws

_tester1 :: Result DataDecl
_tester1 :: Result DataDecl
_tester1 =
  (forall (st :: ZeroBitType). Parser st () DataDecl)
-> ByteString -> Result DataDecl
forall a.
(forall (st :: ZeroBitType). Parser st () a)
-> ByteString -> Result a
parsepure0
    Parser st () DataDecl
forall (st :: ZeroBitType). Parser st () DataDecl
P DataDecl
datadecl
    ByteString
"data A {\
    \  field1 :: Type via Type @A @i @223 a b (C @i),\
    \  field2 :: Type,\
    \  deriving (B) and shadow deriving (Pack, Unpack) with (D, E)\
    \}"

_tester2 :: Result DataDecl
_tester2 :: Result DataDecl
_tester2 =
  (forall (st :: ZeroBitType). Parser st () DataDecl)
-> ByteString -> Result DataDecl
forall a.
(forall (st :: ZeroBitType). Parser st () a)
-> ByteString -> Result a
parsepure0
    Parser st () DataDecl
forall (st :: ZeroBitType). Parser st () DataDecl
P DataDecl
datadecl
    ByteString
"data B {\
    \ field1 :: Type,\
    \ deriving (C)\
    \}"

thhasktype :: P TH.Type
thhasktype :: P Type
thhasktype =
  -- only cover: ParensT, TupleT, AppT, AppKindT, ForallT,
  -- VarT, ConT, PromotedT, LitT, ListT.
  -- no functions or other infix operators.
  Parser st r ()
P ()
ws Parser st r ()
-> ParserT st r ParseError Type -> ParserT st r ParseError Type
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParserT st r ParseError Type]
forall {st :: ZeroBitType} {r}. [ParserT st r ParseError Type]
parsers
  where
    -- caution: if vart were attempted first then appkindt, forallt, etc.
    -- may be subsumed by it, by nature of the grammar. so attempt
    -- these more specific ones first. same for appt vs. cont and others.
    parsers :: [ParserT st r ParseError Type]
parsers =
      [ParserT st r ParseError Type
P Type
litt, ParserT st r ParseError Type
listt, ParserT st r ParseError Type
P Type
promotedt, ParserT st r ParseError Type
appkindt]
        [ParserT st r ParseError Type]
-> [ParserT st r ParseError Type] -> [ParserT st r ParseError Type]
forall a. [a] -> [a] -> [a]
++ [ParserT st r ParseError Type
tuplet, ParserT st r ParseError Type
forallt, ParserT st r ParseError Type
appt, ParserT st r ParseError Type
P Type
cont, ParserT st r ParseError Type
P Type
vart]
    vart0 :: ParserT st r ParseError Name
vart0 = (String -> Name
TH.mkName (String -> Name)
-> ParserT st r ParseError String -> ParserT st r ParseError Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> String -> String)
-> ParserT st r ParseError Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall a b c.
(a -> b -> c)
-> ParserT st r ParseError a
-> ParserT st r ParseError b
-> ParserT st r ParseError c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
vahead (ParserT st r ParseError Char -> ParserT st r ParseError String
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
chtail)) ParserT st r ParseError Name
-> ParserT st r ParseError () -> ParserT st r ParseError Name
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
    cont0 :: ParserT st r ParseError Name
cont0 = (String -> Name
TH.mkName (String -> Name)
-> ParserT st r ParseError String -> ParserT st r ParseError Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> String -> String)
-> ParserT st r ParseError Char
-> ParserT st r ParseError String
-> ParserT st r ParseError String
forall a b c.
(a -> b -> c)
-> ParserT st r ParseError a
-> ParserT st r ParseError b
-> ParserT st r ParseError c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
cohead (ParserT st r ParseError Char -> ParserT st r ParseError String
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT st r ParseError Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
chtail)) ParserT st r ParseError Name
-> ParserT st r ParseError () -> ParserT st r ParseError Name
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
    cont :: ParserT st r ParseError Type
cont = Name -> Type
TH.ConT (Name -> Type)
-> ParserT st r ParseError Name -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Name
forall {st :: ZeroBitType} {r}. ParserT st r ParseError Name
cont0
    vart :: ParserT st r ParseError Type
vart = Name -> Type
TH.VarT (Name -> Type)
-> ParserT st r ParseError Name -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Name
forall {st :: ZeroBitType} {r}. ParserT st r ParseError Name
vart0
    appt :: ParserT st r ParseError Type
appt =
      (Type -> Type -> Type) -> NonEmpty Type -> Type
forall (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
foldl1' Type -> Type -> Type
TH.AppT (NonEmpty Type -> Type)
-> ([Type] -> NonEmpty Type) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> NonEmpty Type
forall a. HasCallStack => [a] -> NonEmpty a
NEL.fromList
        ([Type] -> Type)
-> ParserT st r ParseError [Type] -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r ParseError Type -> ParserT st r ParseError [Type]
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some do
          forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice @[]
            [ParserT st r ParseError Type
P Type
cont, ParserT st r ParseError Type
P Type
vart, ParserT st r ParseError Type
tuplet, ParserT st r ParseError Type
P Type
litt, ParserT st r ParseError Type
listt, ParserT st r ParseError Type
P Type
promotedt]
        ParserT st r ParseError Type
-> ParserT st r ParseError () -> ParserT st r ParseError Type
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
    tuplet :: ParserT st r ParseError Type
tuplet =
      let prefix :: ParserT st r ParseError Type
prefix = ParserT st r ParseError ()
-> ParserT st r ParseError ()
-> ParserT st r ParseError [()]
-> ParserT st r ParseError [()]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParserT st r ParseError ()
P ()
lpar ParserT st r ParseError ()
P ()
rpar (ParserT st r ParseError () -> ParserT st r ParseError [()]
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParserT st r ParseError ()
P ()
comma) ParserT st r ParseError [()]
-> ([()] -> Type) -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Int -> Type
TH.TupleT (Int -> Type) -> ([()] -> Int) -> [()] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
          regular :: ParserT st r ParseError Type
regular = ParserT st r ParseError ()
-> ParserT st r ParseError ()
-> ParserT st r ParseError Type
-> ParserT st r ParseError Type
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParserT st r ParseError ()
P ()
lpar ParserT st r ParseError ()
P ()
rpar do
            items <- (ParserT st r ParseError Type
 -> ParserT st r ParseError () -> ParserT st r ParseError [Type])
-> ParserT st r ParseError ()
-> ParserT st r ParseError Type
-> ParserT st r ParseError [Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParserT st r ParseError Type
-> ParserT st r ParseError () -> ParserT st r ParseError [Type]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy ParserT st r ParseError ()
P ()
comma do [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParserT st r ParseError Type]
parsers
            pure case items of
              Type
i : [] -> Type -> Type
TH.ParensT Type
i
              [Type]
_ -> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
TH.AppT (Int -> Type
TH.TupleT ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
items)) [Type]
items
       in ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError Type -> ParserT st r ParseError Type
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParserT st r ParseError Type
P Type
prefix ParserT st r ParseError Type
-> ParserT st r ParseError Type -> ParserT st r ParseError Type
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> ParserT st r ParseError Type
regular) ParserT st r ParseError Type
-> ParserT st r ParseError () -> ParserT st r ParseError Type
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
    appkindt :: ParserT st r ParseError Type
appkindt = do
      base <- [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParserT st r ParseError Type
P Type
cont, ParserT st r ParseError Type
P Type
vart, ParserT st r ParseError Type
tuplet]
      foldl' (flip ($)) base <$> many do
        let next = [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParserT st r ParseError Type
P Type
litt, ParserT st r ParseError Type
listt, ParserT st r ParseError Type
P Type
promotedt, ParserT st r ParseError Type
tuplet, ParserT st r ParseError Type
P Type
cont, ParserT st r ParseError Type
P Type
vart]
        choice
          [ (flip TH.AppKindT <$> (atsymb *> next)),
            (flip TH.AppT <$> next)
          ]
    forallt :: ParserT st r ParseError Type
forallt = do
      -- no KindedTV (that is, (a :: k) form) support yet
      ns <- $(string "forall") ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError [Name] -> ParserT st r ParseError [Name]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError Name -> ParserT st r ParseError [Name]
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT st r ParseError Name
forall {st :: ZeroBitType} {r}. ParserT st r ParseError Name
vart0
      let vars = [Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
name Specificity
TH.SpecifiedSpec | Name
name <- [Name]
ns]
      $(char '.') *> ws
      ct <- option [] do
        between lpar rpar (sepBy1 (choice [appt, cont]) comma)
      unless (null ct) do
        ws <* $(string "=>") <* ws
      TH.ForallT vars ct <$> choice do
        [litt, listt, promotedt, appkindt, tuplet, appt, cont, vart]
    promotedt :: ParserT st r ParseError Type
promotedt = Name -> Type
TH.PromotedT (Name -> Type)
-> ParserT st r ParseError Name -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParserT st r ParseError ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
quote ParserT st r ParseError ()
-> ParserT st r ParseError Name -> ParserT st r ParseError Name
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError Name
forall {st :: ZeroBitType} {r}. ParserT st r ParseError Name
cont0) -- data con
    litt :: ParserT st r ParseError Type
litt = TyLit -> Type
TH.LitT (TyLit -> Type)
-> ParserT st r ParseError TyLit -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ParserT st r ParseError TyLit] -> ParserT st r ParseError TyLit
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParserT st r ParseError TyLit
forall {st :: ZeroBitType} {r} {e}. ParserT st r e TyLit
numtylit, ParserT st r ParseError TyLit
forall {st :: ZeroBitType} {r} {e}. ParserT st r e TyLit
strtylit, ParserT st r ParseError TyLit
forall {st :: ZeroBitType} {r} {e}. ParserT st r e TyLit
chartylit] ParserT st r ParseError TyLit
-> ParserT st r ParseError () -> ParserT st r ParseError TyLit
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws)
    listt :: ParserT st r ParseError Type
listt =
      ParserT st r ParseError ()
-> ParserT st r ParseError ()
-> ParserT st r ParseError Type
-> ParserT st r ParseError Type
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParserT st r ParseError ()
P ()
llist ParserT st r ParseError ()
P ()
rlist (ParserT st r ParseError Type -> ParserT st r ParseError Type)
-> ParserT st r ParseError Type -> ParserT st r ParseError Type
forall a b. (a -> b) -> a -> b
$
        (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
TH.AppT Type
TH.ListT
          ([Type] -> Type)
-> ParserT st r ParseError [Type] -> ParserT st r ParseError Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParserT st r ParseError Type
 -> ParserT st r ParseError () -> ParserT st r ParseError [Type])
-> ParserT st r ParseError ()
-> ParserT st r ParseError Type
-> ParserT st r ParseError [Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParserT st r ParseError Type
-> ParserT st r ParseError () -> ParserT st r ParseError [Type]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy ParserT st r ParseError ()
P ()
comma do
            [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParserT st r ParseError Type] -> ParserT st r ParseError Type)
-> [ParserT st r ParseError Type] -> ParserT st r ParseError Type
forall a b. (a -> b) -> a -> b
$
              [ParserT st r ParseError Type
P Type
litt, ParserT st r ParseError Type
listt, ParserT st r ParseError Type
P Type
promotedt, ParserT st r ParseError Type
appkindt]
                [ParserT st r ParseError Type]
-> [ParserT st r ParseError Type] -> [ParserT st r ParseError Type]
forall a. [a] -> [a] -> [a]
++ [ParserT st r ParseError Type
tuplet, ParserT st r ParseError Type
forallt, ParserT st r ParseError Type
appt, ParserT st r ParseError Type
P Type
cont, ParserT st r ParseError Type
P Type
vart]
    lpar :: ParserT st r ParseError ()
lpar = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '(') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
    rpar :: ParserT st r ParseError ()
rpar = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char ')') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
    comma :: ParserT st r ParseError ()
comma = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char ',') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
    atsymb :: ParserT st r ParseError ()
atsymb = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '@') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st r ParseError ()
P ()
ws
    quote :: ParserT st r e ()
quote = $(char '\'')
    dbquote :: ParserT st r e ()
dbquote = $(char '"')
    bksp :: ParserT st r e ()
bksp = $(char '\\')
    llist :: ParserT st r ParseError ()
llist = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '[') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
    rlist :: ParserT st r ParseError ()
rlist = ParserT st r ParseError ()
P ()
ws ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char ']') ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError ()
P ()
ws
    vahead :: ParserT st r e Char
vahead = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfy \Char
c -> (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    cohead :: ParserT st r e Char
cohead = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfy \Char
c -> (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    chtail :: ParserT st r e Char
chtail = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfy \Char
c ->
      Char -> Bool
isLetter Char
c
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
        Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
    numtylit :: ParserT st r e TyLit
numtylit = Integer -> TyLit
TH.NumTyLit (Integer -> TyLit)
-> ParserT st r e Integer -> ParserT st r e TyLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r e Integer
forall (st :: ZeroBitType) r e. ParserT st r e Integer
anyAsciiDecimalInteger
    strtylit :: ParserT st r e TyLit
strtylit = String -> TyLit
TH.StrTyLit (String -> TyLit) -> ParserT st r e String -> ParserT st r e TyLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r e ()
-> ParserT st r e ()
-> ParserT st r e String
-> ParserT st r e String
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
dbquote ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
dbquote (ParserT st r e Char -> ParserT st r e String
forall a. ParserT st r e a -> ParserT st r e [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
escaped)
    chartylit :: ParserT st r e TyLit
chartylit = Char -> TyLit
TH.CharTyLit (Char -> TyLit) -> ParserT st r e Char -> ParserT st r e TyLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT st r e ()
-> ParserT st r e () -> ParserT st r e Char -> ParserT st r e Char
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
quote ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
quote ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
escaped'
    escaped :: ParserT st r e Char
escaped = ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
approved ParserT st r e Char -> ParserT st r e Char -> ParserT st r e Char
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
bksp ParserT st r e () -> ParserT st r e () -> ParserT st r e ()
forall a b.
ParserT st r e a -> ParserT st r e b -> ParserT st r e b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
dbquote ParserT st r e () -> Char -> ParserT st r e Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'"')
    escaped' :: ParserT st r e Char
escaped' = ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Char
approved ParserT st r e Char -> ParserT st r e Char -> ParserT st r e Char
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
bksp ParserT st r e () -> ParserT st r e () -> ParserT st r e ()
forall a b.
ParserT st r e a -> ParserT st r e b -> ParserT st r e b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r e ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
quote ParserT st r e () -> Char -> ParserT st r e Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\'')
    approved :: ParserT st r e Char
approved = (Char -> Bool) -> ParserT st r e Char
forall {st :: ZeroBitType} {r} {e}.
(Char -> Bool) -> ParserT st r e Char
satisfy Char -> Bool
isPrint

infixr 3 #

(#) :: TH.Q a -> TH.Q [a] -> TH.Q [a]
# :: forall a. Q a -> Q [a] -> Q [a]
(#) = (a -> [a] -> [a]) -> Q a -> Q [a] -> Q [a]
forall a b c. (a -> b -> c) -> Q a -> Q b -> Q c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:)

data PkState = PkState
  { PkState -> [Type]
pkderp :: [TH.Type],
    PkState -> [Type]
pkders :: [TH.Type]
  }
  deriving (Int -> PkState -> String -> String
[PkState] -> String -> String
PkState -> String
(Int -> PkState -> String -> String)
-> (PkState -> String)
-> ([PkState] -> String -> String)
-> Show PkState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PkState -> String -> String
showsPrec :: Int -> PkState -> String -> String
$cshow :: PkState -> String
show :: PkState -> String
$cshowList :: [PkState] -> String -> String
showList :: [PkState] -> String -> String
Show, Typeable)

-- user-facing

-- | Set up default derives for subsequent data types.
-- This sets 'Generic' for proper derives and 'Generic' + 'Pack' + 'Unpack' for shadow derives.
--
-- Use this at the start of your module to automatically derive the most common instances.
setdefaultderives :: TH.Q [TH.Dec]
setdefaultderives :: Q [Dec]
setdefaultderives = do
  Q ()
pkinit
  (PkState -> PkState) -> Q ()
pkmodify \PkState
b -> PkState
b {pkderp = TH.ConT <$> [''Generic]}
  (PkState -> PkState) -> Q ()
pkmodify \PkState
b -> PkState
b {pkders = TH.ConT <$> [''Generic, ''Pack, ''Unpack]}
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Add proper deriving clauses for subsequent data types.
-- These instances will be derived directly on the main data type.
--
-- @
-- 'addproperderives' [''Generic, ''Show]  -- Derive Generic and Show
-- @
addproperderives :: [TH.Name] -> TH.Q [TH.Dec]
addproperderives :: [Name] -> Q [Dec]
addproperderives [Name]
names = do
  Q ()
pkinit
  (PkState -> PkState) -> Q ()
pkmodify \PkState
b -> PkState
b {pkderp = b.pkderp ++ map TH.ConT names}
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Add shadow deriving clauses for subsequent data types.
-- These instances will be derived on the shadow data type used for serialization.
--
-- @
-- 'addshadowderives' [''Generic, ''Pack]  -- Derive 'Generic' and 'Pack' on shadow type
-- @
addshadowderives :: [TH.Name] -> TH.Q [TH.Dec]
addshadowderives :: [Name] -> Q [Dec]
addshadowderives [Name]
names = do
  Q ()
pkinit
  (PkState -> PkState) -> Q ()
pkmodify \PkState
b -> PkState
b {pkders = b.pkders ++ map TH.ConT names}
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

pkinit :: TH.Q ()
pkinit :: Q ()
pkinit =
  Q (Maybe PkState)
forall a. Typeable a => Q (Maybe a)
TH.getQ Q (Maybe PkState) -> (Maybe PkState -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (PkState
_ :: PkState) -> Q ()
forall (m :: * -> *). Applicative m => m ()
noop
    Maybe PkState
Nothing -> PkState -> Q ()
pkput (PkState -> Q ()) -> PkState -> Q ()
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type] -> PkState
PkState [] []

pkput :: PkState -> TH.Q ()
pkput :: PkState -> Q ()
pkput = PkState -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ

pkget :: TH.Q PkState
pkget :: Q PkState
pkget =
  Q (Maybe PkState)
forall a. Typeable a => Q (Maybe a)
TH.getQ Q (Maybe PkState) -> (Maybe PkState -> PkState) -> Q PkState
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just PkState
s -> PkState
s
    Maybe PkState
Nothing -> String -> PkState
forall a. HasCallStack => String -> a
error String
"pkget failed"

pkmodify :: (PkState -> PkState) -> TH.Q ()
pkmodify :: (PkState -> PkState) -> Q ()
pkmodify PkState -> PkState
f = do
  a <- Q PkState
pkget
  pkput (f a)

pkmacrobody :: [DataDecl] -> TH.Q [TH.Dec]
pkmacrobody :: [DataDecl] -> Q [Dec]
pkmacrobody [DataDecl]
decls = do
  Q ()
pkinit
  pkstate <- Q PkState
pkget
  concat <$> do
    forM decls \DataDecl
decl -> do
      let ders :: [Type]
ders = PkState
pkstate.pkders [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ DataDecl
decl.dataders
          derp :: [Type]
derp = PkState
pkstate.pkderp [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ DataDecl
decl.dataderp
          nobang :: Bang
nobang = SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang SourceUnpackedness
TH.NoSourceUnpackedness SourceStrictness
TH.NoSourceStrictness
          shadowed :: Bool
shadowed = (Field -> Bool) -> [Field] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Type -> Bool) -> (Field -> Maybe Type) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldType -> Maybe Type
typevia (FieldType -> Maybe Type)
-> (Field -> FieldType) -> Field -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> FieldType
fieldtype) DataDecl
decl.dataflds
          maindecl :: Q Dec
maindecl =
            Q [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
TH.dataD
              ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) -- Cxt
              DataDecl
decl.dataname
              [] -- no type variables
              Maybe Type
forall a. Maybe a
Nothing -- no exotic kind
              [ Name -> [Q VarBangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
TH.recC
                  DataDecl
decl.dataname
                  [ VarBangType -> Q VarBangType
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field
f.fieldname, Bang
nobang, Field
f.fieldtype.typemain)
                  | Field
f <- DataDecl
decl.dataflds
                  ]
              ]
              ( [ Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
TH.derivClause
                    Maybe DerivStrategy
forall a. Maybe a
Nothing
                    ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
derp)
                ]
                  [Q DerivClause] -> [Q DerivClause] -> [Q DerivClause]
forall a. [a] -> [a] -> [a]
++ if Bool
shadowed
                    then
                      []
                    else
                      [ Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
TH.derivClause
                          Maybe DerivStrategy
forall a. Maybe a
Nothing
                          ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type]
ders [Type] -> [Type] -> [Type]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Type]
derp))
                      ]
              )
          mkshadow :: Name -> Name
mkshadow (TH.Name (TH.OccName String
n) NameFlavour
nf) =
            OccName -> NameFlavour -> Name
TH.Name (String -> OccName
TH.OccName (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__")) NameFlavour
nf
          shadowdecl :: Q Dec
shadowdecl =
            Q [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
TH.dataD
              ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) -- no Cxt
              (Name -> Name
mkshadow DataDecl
decl.dataname)
              []
              Maybe Type
forall a. Maybe a
Nothing
              [ Name -> [Q VarBangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
TH.recC
                  (Name -> Name
mkshadow DataDecl
decl.dataname)
                  ( [ VarBangType -> Q VarBangType
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarBangType -> Q VarBangType) -> VarBangType -> Q VarBangType
forall a b. (a -> b) -> a -> b
$
                        VarBangType -> (Type -> VarBangType) -> Maybe Type -> VarBangType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                          (Name
n, Bang
nobang, Field
f.fieldtype.typemain)
                          (\Type
v -> (Name
n, Bang
nobang, Type
v))
                          Field
f.fieldtype.typevia
                    | Field
f <- DataDecl
decl.dataflds,
                      let n :: Name
n = Name -> Name
mkshadow Field
f.fieldname
                    ]
                  )
              ]
              [ Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
TH.derivClause
                  Maybe DerivStrategy
forall a. Maybe a
Nothing
                  ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
ders)
              ]
          bridgepack :: Q Dec
bridgepack = do
            self <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"self"
            TH.instanceD
              (pure []) -- no Cxt
              (TH.appT (TH.conT ''Pack) (TH.conT decl.dataname))
              [ TH.funD
                  'pack
                  [ [] & TH.clause [TH.varP self] do
                      TH.normalB do
                        names <- forM decl.dataflds (const (TH.newName "a"))
                        TH.letE
                          [ TH.valD
                              (TH.conP decl.dataname (TH.varP <$> names))
                              (TH.normalB (TH.varE self))
                              [] -- no where-bindings
                          ]
                          ( TH.appE (TH.varE 'pack) do
                              TH.appsE do
                                TH.conE (mkshadow decl.dataname)
                                  : [ TH.appE (TH.varE 'coerce) (TH.varE n)
                                    | n <- names
                                    ]
                          )
                  ]
              ]
          bridgeunpack :: Q Dec
bridgeunpack = do
            other <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"other"
            TH.instanceD
              (pure []) -- no Cxt
              (TH.appT (TH.conT ''Unpack) (TH.conT decl.dataname))
              [ [] & TH.valD (TH.varP 'unpack) do
                  TH.normalB do
                    names <- forM decl.dataflds (const (TH.newName "a"))
                    TH.doE
                      [ TH.bindS (TH.varP other) (TH.varE 'unpack),
                        TH.letS
                          [ TH.valD
                              ( TH.conP
                                  (mkshadow decl.dataname)
                                  (TH.varP <$> names)
                              )
                              (TH.normalB (TH.varE other))
                              []
                          ],
                        TH.noBindS do
                          TH.appE (TH.varE 'pure) do
                            TH.appsE do
                              TH.conE decl.dataname
                                : [ TH.appE (TH.varE 'coerce) (TH.varE n)
                                  | n <- names
                                  ]
                      ]
              ]
      Q Dec
maindecl
        # if shadowed
          then sequence [shadowdecl, bridgepack, bridgeunpack]
          else pure []

punwrap :: Result a -> a
punwrap :: forall a. Result a -> a
punwrap (OK a
v Int
_ ByteString
_) = a
v
punwrap Result ParseError a
Fail = String -> a
forall a. HasCallStack => String -> a
error String
"unexpected uninformative failure"
punwrap (Err ParseError
e) = String -> a
forall a. HasCallStack => String -> a
error (String
"parsing error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
showparseerror ParseError
e)

-- | See module docs ("M.PkMacro") for information.
pkmacro :: TH.QuasiQuoter
pkmacro :: QuasiQuoter
pkmacro =
  TH.QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
"pkmacro is not an expression quoter",
      quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"pkmacro is not a pattern quoter",
      quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"pkmacro is not a type quoter",
      quoteDec :: String -> Q [Dec]
quoteDec =
        [DataDecl] -> Q [Dec]
pkmacrobody
          ([DataDecl] -> Q [Dec])
-> (String -> [DataDecl]) -> String -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result [DataDecl] -> [DataDecl]
forall a. Result a -> a
punwrap
          (Result [DataDecl] -> [DataDecl])
-> (String -> Result [DataDecl]) -> String -> [DataDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (st :: ZeroBitType). Parser st () [DataDecl])
-> ByteString -> Result [DataDecl]
forall a.
(forall (st :: ZeroBitType). Parser st () a)
-> ByteString -> Result a
parsepure0 (Parser st () [DataDecl] -> Parser st () [DataDecl]
forall (st :: ZeroBitType) r a. Parser st r a -> Parser st r a
ewrap (Parser st () [DataDecl] -> ParseError -> Parser st () [DataDecl]
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut (ParserT st () ParseError DataDecl -> Parser st () [DataDecl]
forall a.
ParserT st () ParseError a -> ParserT st () ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParserT st () ParseError DataDecl
P DataDecl
datadecl Parser st () [DataDecl]
-> ParserT st () ParseError () -> Parser st () [DataDecl]
forall a b.
ParserT st () ParseError a
-> ParserT st () ParseError b -> ParserT st () ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT st () ParseError ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
eof) ParseError
"pkmacro parse"))
          (ByteString -> Result [DataDecl])
-> (String -> ByteString) -> String -> Result [DataDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
strToUtf8
    }