{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module      : Data.Array.Accelerate.Pattern.TH
-- Copyright   : [2018..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Pattern.TH (

  mkPattern,
  mkPatterns,

) where

import Data.Array.Accelerate.AST.Idx
import Data.Array.Accelerate.Pattern
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Sugar.Elt
import Data.Array.Accelerate.Type

import Control.Monad
import Data.Bits
import Data.Char
import Data.List                                                    ( (\\), foldl' )
import Language.Haskell.TH.Extra                                    hiding ( Exp, Match, match )
import Numeric
import Text.Printf
import qualified Language.Haskell.TH.Extra                          as TH

import GHC.Stack


-- | As 'mkPattern', but for a list of types
--
mkPatterns :: [Name] -> DecsQ
mkPatterns :: [Name] -> DecsQ
mkPatterns [Name]
nms = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DecsQ) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> DecsQ
mkPattern [Name]
nms

-- | Generate pattern synonyms for the given simple (Haskell'98) sum or
-- product data type.
--
-- Constructor and record selectors are renamed to add a trailing
-- underscore if it does not exist, or to remove it if it does. For infix
-- constructors, the name is prepended with a colon ':'. For example:
--
-- > data Point = Point { xcoord_ :: Float, ycoord_ :: Float }
-- >   deriving (Generic, Elt)
--
-- Will create the pattern synonym:
--
-- > Point_ :: Exp Float -> Exp Float -> Exp Point
--
-- together with the selector functions
--
-- > xcoord :: Exp Point -> Exp Float
-- > ycoord :: Exp Point -> Exp Float
--
mkPattern :: Name -> DecsQ
mkPattern :: Name -> DecsQ
mkPattern Name
nm = do
  Info
info <- Name -> Q Info
reify Name
nm
  case Info
info of
    TyConI Dec
dec -> Dec -> DecsQ
mkDec Dec
dec
    Info
_          -> String -> DecsQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: expected the name of a newtype or datatype"

mkDec :: Dec -> DecsQ
mkDec :: Dec -> DecsQ
mkDec Dec
dec =
  case Dec
dec of
    DataD    Cxt
_ Name
nm [TyVarBndr ()]
tv Maybe Kind
_ [Con]
cs [DerivClause]
_ -> Name -> [TyVarBndr ()] -> [Con] -> DecsQ
forall a. Name -> [TyVarBndr a] -> [Con] -> DecsQ
mkDataD Name
nm [TyVarBndr ()]
tv [Con]
cs
    NewtypeD Cxt
_ Name
nm [TyVarBndr ()]
tv Maybe Kind
_ Con
c  [DerivClause]
_ -> Name -> [TyVarBndr ()] -> Con -> DecsQ
forall a. Name -> [TyVarBndr a] -> Con -> DecsQ
mkNewtypeD Name
nm [TyVarBndr ()]
tv Con
c
    Dec
_                       -> String -> DecsQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: expected the name of a newtype or datatype"

mkNewtypeD :: Name -> [TyVarBndr a] -> Con -> DecsQ
mkNewtypeD :: forall a. Name -> [TyVarBndr a] -> Con -> DecsQ
mkNewtypeD Name
tn [TyVarBndr a]
tvs Con
c = Name -> [TyVarBndr a] -> [Con] -> DecsQ
forall a. Name -> [TyVarBndr a] -> [Con] -> DecsQ
mkDataD Name
tn [TyVarBndr a]
tvs [Con
c]

mkDataD :: Name -> [TyVarBndr a] -> [Con] -> DecsQ
mkDataD :: forall a. Name -> [TyVarBndr a] -> [Con] -> DecsQ
mkDataD Name
tn [TyVarBndr a]
tvs [Con]
cs = do
  ([Name]
pats, [[Dec]]
decs) <- [(Name, [Dec])] -> ([Name], [[Dec]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, [Dec])] -> ([Name], [[Dec]]))
-> Q [(Name, [Dec])] -> Q ([Name], [[Dec]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> Q [(Name, [Dec])]
go [Con]
cs
  Dec
comp         <- [Name] -> Maybe Name -> Q Dec
forall (m :: * -> *). Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD [Name]
pats Maybe Name
forall a. Maybe a
Nothing
  [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ Dec
comp Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs
  where
    -- For single-constructor types we create the pattern synonym for the
    -- type directly in terms of Pattern
    go :: [Con] -> Q [(Name, [Dec])]
go []  = String -> Q [(Name, [Dec])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: empty data declarations not supported"
    go [Con
c] = (Name, [Dec]) -> [(Name, [Dec])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Dec]) -> [(Name, [Dec])])
-> Q (Name, [Dec]) -> Q [(Name, [Dec])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [TyVarBndr a] -> Con -> Q (Name, [Dec])
forall a. Name -> [TyVarBndr a] -> Con -> Q (Name, [Dec])
mkConP Name
tn [TyVarBndr a]
tvs Con
c
    go [Con]
_   = [Cxt] -> [Cxt] -> [Word8] -> [Con] -> Q [(Name, [Dec])]
go' [] ((Con -> Cxt) -> [Con] -> [Cxt]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Cxt
fieldTys [Con]
cs) [Word8]
ctags [Con]
cs

    -- For sum-types, when creating the pattern for an individual
    -- constructor we need to know about the types of the fields all other
    -- constructors as well
    go' :: [Cxt] -> [Cxt] -> [Word8] -> [Con] -> Q [(Name, [Dec])]
go' [Cxt]
prev (Cxt
this:[Cxt]
next) (Word8
tag:[Word8]
tags) (Con
con:[Con]
cons) = do
      (Name, [Dec])
r  <- Name
-> [TyVarBndr a]
-> [Cxt]
-> [Cxt]
-> Word8
-> Con
-> Q (Name, [Dec])
forall a.
Name
-> [TyVarBndr a]
-> [Cxt]
-> [Cxt]
-> Word8
-> Con
-> Q (Name, [Dec])
mkConS Name
tn [TyVarBndr a]
tvs [Cxt]
prev [Cxt]
next Word8
tag Con
con
      [(Name, [Dec])]
rs <- [Cxt] -> [Cxt] -> [Word8] -> [Con] -> Q [(Name, [Dec])]
go' (Cxt
thisCxt -> [Cxt] -> [Cxt]
forall a. a -> [a] -> [a]
:[Cxt]
prev) [Cxt]
next [Word8]
tags [Con]
cons
      [(Name, [Dec])] -> Q [(Name, [Dec])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Dec])
r (Name, [Dec]) -> [(Name, [Dec])] -> [(Name, [Dec])]
forall a. a -> [a] -> [a]
: [(Name, [Dec])]
rs)
    go' [Cxt]
_ [] [] [] = [(Name, [Dec])] -> Q [(Name, [Dec])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go' [Cxt]
_ [Cxt]
_  [Word8]
_  [Con]
_  = String -> Q [(Name, [Dec])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: unexpected error"

    fieldTys :: Con -> Cxt
fieldTys (NormalC Name
_ [BangType]
fs) = (BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
fs
    fieldTys (RecC Name
_ [VarBangType]
fs)    = (VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
_,Kind
t) -> Kind
t) [VarBangType]
fs
    fieldTys (InfixC BangType
a Name
_ BangType
b) = [BangType -> Kind
forall a b. (a, b) -> b
snd BangType
a, BangType -> Kind
forall a b. (a, b) -> b
snd BangType
b]
    fieldTys Con
_              = String -> Cxt
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: only constructors for \"vanilla\" syntax are supported"

    -- TODO: The GTags class demonstrates a way to generate the tags for
    -- a given constructor, rather than backwards-engineering the structure
    -- as we've done here. We should use that instead!
    --
    ctags :: [Word8]
ctags =
      let n :: Int
n = [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cs
          m :: Int
m = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
2
          l :: [[Bool]]
l = Int -> [[Bool]] -> [[Bool]]
forall a. Int -> [a] -> [a]
take Int
m     (([Bool] -> [Bool]) -> [Bool] -> [[Bool]]
forall a. (a -> a) -> a -> [a]
iterate (Bool
TrueBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:) [Bool
False])
          r :: [[Bool]]
r = Int -> [[Bool]] -> [[Bool]]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (([Bool] -> [Bool]) -> [Bool] -> [[Bool]]
forall a. (a -> a) -> a -> [a]
iterate (Bool
TrueBool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
:) [Bool
True])
          --
          bitsToTag :: [Bool] -> Word8
bitsToTag = (Word8 -> Bool -> Word8) -> Word8 -> [Bool] -> Word8
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word8 -> Bool -> Word8
forall {a}. Bits a => a -> Bool -> a
f Word8
0
            where
              f :: a -> Bool -> a
f a
i Bool
False =         a
i a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
              f a
i Bool
True  = a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit (a
i a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int
0
      in
      ([Bool] -> Word8) -> [[Bool]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map [Bool] -> Word8
bitsToTag ([[Bool]]
l [[Bool]] -> [[Bool]] -> [[Bool]]
forall a. [a] -> [a] -> [a]
++ [[Bool]]
r)


mkConP :: Name -> [TyVarBndr a] -> Con -> Q (Name, [Dec])
mkConP :: forall a. Name -> [TyVarBndr a] -> Con -> Q (Name, [Dec])
mkConP Name
tn' [TyVarBndr a]
tvs' Con
con' = do
  [Extension] -> Q ()
checkExts [ Extension
PatternSynonyms ]
  case Con
con' of
    NormalC Name
cn [BangType]
fs -> Name -> Name -> [Name] -> Cxt -> Q (Name, [Dec])
mkNormalC Name
tn' Name
cn ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
fs)
    RecC Name
cn [VarBangType]
fs    -> Name -> Name -> [Name] -> [Name] -> Cxt -> Q (Name, [Dec])
mkRecC Name
tn' Name
cn ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') ((VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name
rename (Name -> Name) -> (VarBangType -> Name) -> VarBangType -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarBangType -> Name
forall a b c. (a, b, c) -> a
fst3) [VarBangType]
fs) ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thd3 [VarBangType]
fs)
    InfixC BangType
a Name
cn BangType
b -> Name -> Name -> [Name] -> Cxt -> Q (Name, [Dec])
mkInfixC Name
tn' Name
cn ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') [BangType -> Kind
forall a b. (a, b) -> b
snd BangType
a, BangType -> Kind
forall a b. (a, b) -> b
snd BangType
b]
    Con
_             -> String -> Q (Name, [Dec])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: only constructors for \"vanilla\" syntax are supported"
  where
    mkNormalC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec])
    mkNormalC :: Name -> Name -> [Name] -> Cxt -> Q (Name, [Dec])
mkNormalC Name
tn Name
cn [Name]
tvs Cxt
fs = do
      [Name]
xs <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x")
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [Name]
xs)
                         Q PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                         [p| Pattern $([Q Pat] -> Q Pat
tupP ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)) |]
                     ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
pat, [Dec]
r)
      where
        pat :: Name
pat = Name -> Name
rename Name
cn
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

    mkRecC :: Name -> Name -> [Name] -> [Name] -> [Type] -> Q (Name, [Dec])
    mkRecC :: Name -> Name -> [Name] -> [Name] -> Cxt -> Q (Name, [Dec])
mkRecC Name
tn Name
cn [Name]
tvs [Name]
xs Cxt
fs = do
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
recordPatSyn [Name]
xs)
                         Q PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                         [p| Pattern $([Q Pat] -> Q Pat
tupP ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)) |]
                     ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
pat, [Dec]
r)
      where
        pat :: Name
pat = Name -> Name
rename Name
cn
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

    mkInfixC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec])
    mkInfixC :: Name -> Name -> [Name] -> Cxt -> Q (Name, [Dec])
mkInfixC Name
tn Name
cn [Name]
tvs Cxt
fs = do
      Maybe Fixity
mf <- Name -> Q (Maybe Fixity)
reifyFixity Name
cn
      Name
_a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_a"
      Name
_b <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_b"
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         (Name -> Name -> Q PatSynArgs
forall (m :: * -> *). Quote m => Name -> Name -> m PatSynArgs
infixPatSyn Name
_a Name
_b)
                         Q PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                         [p| Pattern $([Q Pat] -> Q Pat
tupP [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_a, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_b]) |]
                     ]
      [Dec]
r' <- case Maybe Fixity
mf of
              Maybe Fixity
Nothing -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
              Just Fixity
f  -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> Name -> Dec
InfixD Fixity
f Name
pat Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
r)
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
pat, [Dec]
r')
      where
        pat :: Name
pat = String -> Name
mkName (Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
cn)
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

mkConS :: Name -> [TyVarBndr a] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec])
mkConS :: forall a.
Name
-> [TyVarBndr a]
-> [Cxt]
-> [Cxt]
-> Word8
-> Con
-> Q (Name, [Dec])
mkConS Name
tn' [TyVarBndr a]
tvs' [Cxt]
prev' [Cxt]
next' Word8
tag' Con
con' = do
  [Extension] -> Q ()
checkExts [Extension
GADTs, Extension
PatternSynonyms, Extension
ScopedTypeVariables, Extension
TypeApplications, Extension
ViewPatterns]
  case Con
con' of
    NormalC Name
cn [BangType]
fs -> Name
-> Name
-> Word8
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkNormalC Name
tn' Name
cn Word8
tag' ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') [Cxt]
prev' ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
fs) [Cxt]
next'
    RecC Name
cn [VarBangType]
fs    -> Name
-> Name
-> Word8
-> [Name]
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkRecC Name
tn' Name
cn Word8
tag' ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') ((VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name
rename (Name -> Name) -> (VarBangType -> Name) -> VarBangType -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarBangType -> Name
forall a b c. (a, b, c) -> a
fst3) [VarBangType]
fs) [Cxt]
prev' ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Kind
forall a b c. (a, b, c) -> c
thd3 [VarBangType]
fs) [Cxt]
next'
    InfixC BangType
a Name
cn BangType
b -> Name
-> Name
-> Word8
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkInfixC Name
tn' Name
cn Word8
tag' ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall flag. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr a]
tvs') [Cxt]
prev' [BangType -> Kind
forall a b. (a, b) -> b
snd BangType
a, BangType -> Kind
forall a b. (a, b) -> b
snd BangType
b] [Cxt]
next'
    Con
_             -> String -> Q (Name, [Dec])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: only constructors for \"vanilla\" syntax are supported"
  where
    mkNormalC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec])
    mkNormalC :: Name
-> Name
-> Word8
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkNormalC Name
tn Name
cn Word8
tag [Name]
tvs [Cxt]
ps Cxt
fs [Cxt]
ns = do
      let pat :: Name
pat = Name -> Name
rename Name
cn
      (Name
fun_build, [Dec]
dec_build) <- Name
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkBuild Name
tn (Name -> String
nameBase Name
cn) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      (Name
fun_match, [Dec]
dec_match) <- Name
-> String
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkMatch Name
tn (Name -> String
nameBase Name
pat) (Name -> String
nameBase Name
cn) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      [Dec]
dec_pat                <- Name -> Name -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkNormalC_pattern Name
tn Name
pat [Name]
tvs Cxt
fs Name
fun_build Name
fun_match
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Dec]) -> Q (Name, [Dec]))
-> (Name, [Dec]) -> Q (Name, [Dec])
forall a b. (a -> b) -> a -> b
$ (Name
pat, [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
dec_pat, [Dec]
dec_build, [Dec]
dec_match])

    mkRecC :: Name -> Name -> Word8 -> [Name] -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec])
    mkRecC :: Name
-> Name
-> Word8
-> [Name]
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkRecC Name
tn Name
cn Word8
tag [Name]
tvs [Name]
xs [Cxt]
ps Cxt
fs [Cxt]
ns = do
      let pat :: Name
pat = Name -> Name
rename Name
cn
      (Name
fun_build, [Dec]
dec_build) <- Name
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkBuild Name
tn (Name -> String
nameBase Name
cn) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      (Name
fun_match, [Dec]
dec_match) <- Name
-> String
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkMatch Name
tn (Name -> String
nameBase Name
pat) (Name -> String
nameBase Name
cn) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      [Dec]
dec_pat                <- Name -> Name -> [Name] -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkRecC_pattern Name
tn Name
pat [Name]
tvs [Name]
xs Cxt
fs Name
fun_build Name
fun_match
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Dec]) -> Q (Name, [Dec]))
-> (Name, [Dec]) -> Q (Name, [Dec])
forall a b. (a -> b) -> a -> b
$ (Name
pat, [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
dec_pat, [Dec]
dec_build, [Dec]
dec_match])

    mkInfixC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec])
    mkInfixC :: Name
-> Name
-> Word8
-> [Name]
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkInfixC Name
tn Name
cn Word8
tag [Name]
tvs [Cxt]
ps Cxt
fs [Cxt]
ns = do
      let pat :: Name
pat = String -> Name
mkName (Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
cn)
      (Name
fun_build, [Dec]
dec_build) <- Name
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkBuild Name
tn (String -> String
zencode (Name -> String
nameBase Name
cn)) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      (Name
fun_match, [Dec]
dec_match) <- Name
-> String
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkMatch Name
tn (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (String -> String
zencode (Name -> String
nameBase Name
cn)) [Name]
tvs Word8
tag [Cxt]
ps Cxt
fs [Cxt]
ns
      [Dec]
dec_pat                <- Name -> Name -> Name -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkInfixC_pattern Name
tn Name
cn Name
pat [Name]
tvs Cxt
fs Name
fun_build Name
fun_match
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Dec]) -> Q (Name, [Dec]))
-> (Name, [Dec]) -> Q (Name, [Dec])
forall a b. (a -> b) -> a -> b
$ (Name
pat, [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
dec_pat, [Dec]
dec_build, [Dec]
dec_match])

    mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q [Dec]
    mkNormalC_pattern :: Name -> Name -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkNormalC_pattern Name
tn Name
pat [Name]
tvs Cxt
fs Name
build Name
match = do
      [Name]
xs <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x")
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [Name]
xs)
                         ([Q Clause] -> Q PatSynDir
forall (m :: * -> *). Quote m => [m Clause] -> m PatSynDir
explBidir [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
build)) []])
                         (Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
match) [p| Just $([Q Pat] -> Q Pat
tupP ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)) |])
                     ]
      [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
      where
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ([t| HasCallStack |] Q Kind -> [Q Kind] -> [Q Kind]
forall a. a -> [a] -> [a]
: (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

    mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q [Dec]
    mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkRecC_pattern Name
tn Name
pat [Name]
tvs [Name]
xs Cxt
fs Name
build Name
match = do
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
recordPatSyn [Name]
xs)
                         ([Q Clause] -> Q PatSynDir
forall (m :: * -> *). Quote m => [m Clause] -> m PatSynDir
explBidir [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
build)) []])
                         (Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
match) [p| Just $([Q Pat] -> Q Pat
tupP ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)) |])
                     ]
      [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
      where
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ([t| HasCallStack |] Q Kind -> [Q Kind] -> [Q Kind]
forall a. a -> [a] -> [a]
: (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

    mkInfixC_pattern :: Name -> Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q [Dec]
    mkInfixC_pattern :: Name -> Name -> Name -> [Name] -> Cxt -> Name -> Name -> DecsQ
mkInfixC_pattern Name
tn Name
cn Name
pat [Name]
tvs Cxt
fs Name
build Name
match = do
      Maybe Fixity
mf <- Name -> Q (Maybe Fixity)
reifyFixity Name
cn
      Name
_a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_a"
      Name
_b <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_b"
      [Dec]
r  <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
pat Q Kind
sig
                     , Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD    Name
pat
                         (Name -> Name -> Q PatSynArgs
forall (m :: * -> *). Quote m => Name -> Name -> m PatSynArgs
infixPatSyn Name
_a Name
_b)
                         ([Q Clause] -> Q PatSynDir
forall (m :: * -> *). Quote m => [m Clause] -> m PatSynDir
explBidir [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
build)) []])
                         (Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
match) [p| Just $([Q Pat] -> Q Pat
tupP [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_a, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_b]) |])
                     ]
      [Dec]
r' <- case Maybe Fixity
mf of
              Maybe Fixity
Nothing -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
              Just Fixity
f  -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> Name -> Dec
InfixD Fixity
f Name
pat Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
r)
      [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r'
      where
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ([t| HasCallStack |] Q Kind -> [Q Kind] -> [Q Kind]
forall a. a -> [a] -> [a]
: (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))

    mkBuild :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec])
    mkBuild :: Name
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkBuild Name
tn String
cn [Name]
tvs Word8
tag [Cxt]
fs0 Cxt
fs [Cxt]
fs1 = do
      Name
fun <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"_build" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cn)
      [Name]
xs  <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x")
      let
        vs :: Q Exp
vs    = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
es Q Exp
e -> [| SmartExp ($Q Exp
es `Pair` $Q Exp
e) |]) [| SmartExp Nil |]
              ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$  (Kind -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [| unExp $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'undef Q Exp -> Q Kind -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Kind -> m Exp
`appTypeE` Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |] ) ([Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Cxt] -> [Cxt]
forall a. [a] -> [a]
reverse [Cxt]
fs0))
              [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs
              [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ (Kind -> Q Exp) -> Cxt -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [| unExp $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'undef Q Exp -> Q Kind -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Kind -> m Exp
`appTypeE` Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |] ) ([Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt]
fs1)

        tagged :: Q Exp
tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
IntegerL (Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger Word8
tag))))) $Q Exp
vs |]
        body :: Q Clause
body   = [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> [p| (Exp $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x)) |]) [Name]
xs) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
tagged) []

      [Dec]
r <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
fun Q Kind
sig
                    , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fun [Q Clause
body]
                    ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fun, [Dec]
r)
      where
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                ((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Q Kind
t Q Kind
ts -> [t| $Q Kind
t -> $Q Kind
ts |])
                       [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) |]
                       ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs))


    mkMatch :: Name -> String -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec])
    mkMatch :: Name
-> String
-> String
-> [Name]
-> Word8
-> [Cxt]
-> Cxt
-> [Cxt]
-> Q (Name, [Dec])
mkMatch Name
tn String
pn String
cn [Name]
tvs Word8
tag [Cxt]
fs0 Cxt
fs [Cxt]
fs1 = do
      Name
fun     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"_match" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cn)
      Name
e       <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_e"
      Name
x       <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_x"
      ([Q Pat]
ps,[Q Exp]
es) <- [Bool] -> Q Exp -> [Q Pat] -> [Q Exp] -> Q ([Q Pat], [Q Exp])
forall {m :: * -> *} {m :: * -> *} {m :: * -> *}.
(Quote m, Quote m, Quote m) =>
[Bool] -> m Exp -> [m Pat] -> [m Exp] -> m ([m Pat], [m Exp])
extract [Bool]
vs [| Prj PairIdxRight $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) |] [] []
      Bool
unbind  <- Extension -> Q Bool
isExtEnabled Extension
RebindableSyntax
      let
        eqE :: Q Exp -> Q Exp
eqE   = if Bool
unbind then [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"==") [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(==))) []]] else Q Exp -> Q Exp
forall a. a -> a
id
        lhs :: Q Pat
lhs   = [p| (Exp $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
e)) |]
        body :: Q Body
body  = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp
eqE (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
e)
          [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SmartExp [(Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Match [[Q Pat] -> Q Pat
forall {m :: * -> *} {t :: * -> *}.
(Quote m, Foldable t) =>
t (m Pat) -> m Pat
matchP [Q Pat]
ps, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x])]) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Just $([Q Exp] -> Q Exp
tupE [Q Exp]
es)  |]) []
          , Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'SmartExp [(Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP 'Match [])])                  (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Nothing          |]) []
          , Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP                                                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| error $Q Exp
error_msg |]) []
          ]

      [Dec]
r <- [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
fun Q Kind
sig
                    , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fun [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
lhs] Q Body
body []]
                    ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fun, [Dec]
r)
      where
        sig :: Q Kind
sig = [TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT
                ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> TyVarBndr Specificity
`plainInvisTV` Specificity
specifiedSpec) [Name]
tvs)
                ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt ([t| HasCallStack |] Q Kind -> [Q Kind] -> [Q Kind]
forall a. a -> [a] -> [a]
: (Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) |]) [Name]
tvs))
                [t| Exp $((Q Kind -> Q Kind -> Q Kind) -> Q Kind -> [Q Kind] -> Q Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tn) ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT [Name]
tvs)) -> Maybe $([Q Kind] -> Q Kind
tupT ((Kind -> Q Kind) -> Cxt -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
t) |]) Cxt
fs)) |]

        matchP :: t (m Pat) -> m Pat
matchP t (m Pat)
us = [p| TagRtag $(Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
IntegerL (Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger Word8
tag))) $m Pat
pat |]
          where
            pat :: m Pat
pat = [p| $((m Pat -> m Pat -> m Pat) -> m Pat -> t (m Pat) -> m Pat
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\m Pat
ps m Pat
p -> [p| TagRpair $m Pat
ps $m Pat
p |]) [p| TagRunit |] t (m Pat)
us) |]

        extract :: [Bool] -> m Exp -> [m Pat] -> [m Exp] -> m ([m Pat], [m Exp])
extract []     m Exp
_ [m Pat]
ps [m Exp]
es = ([m Pat], [m Exp]) -> m ([m Pat], [m Exp])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([m Pat]
ps, [m Exp]
es)
        extract (Bool
u:[Bool]
us) m Exp
x [m Pat]
ps [m Exp]
es = do
          Name
_u <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_u"
          let x' :: m Exp
x' = [| Prj PairIdxLeft (SmartExp $m Exp
x) |]
          if Bool -> Bool
not Bool
u
             then [Bool] -> m Exp -> [m Pat] -> [m Exp] -> m ([m Pat], [m Exp])
extract [Bool]
us m Exp
x' (m Pat
forall (m :: * -> *). Quote m => m Pat
wildPm Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
:[m Pat]
ps)  [m Exp]
es
             else [Bool] -> m Exp -> [m Pat] -> [m Exp] -> m ([m Pat], [m Exp])
extract [Bool]
us m Exp
x' (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_um Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
:[m Pat]
ps) ([| Exp (SmartExp (Match $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_u) (SmartExp (Prj PairIdxRight (SmartExp $m Exp
x))))) |] m Exp -> [m Exp] -> [m Exp]
forall a. a -> [a] -> [a]
: [m Exp]
es)

        vs :: [Bool]
vs = [Bool] -> [Bool]
forall a. [a] -> [a]
reverse
           ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ [ Bool
False | Kind
_ <- [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt]
fs0 ] [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [ Bool
True | Kind
_ <- Cxt
fs ] [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [ Bool
False | Kind
_ <- [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt]
fs1 ]

        error_msg :: Q Exp
error_msg =
          let pv :: String
pv = [String] -> String
unwords
                 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> [[String]] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
reverse)
                 ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> [String] -> [[String]]
forall a. (a -> a) -> a -> [a]
iterate ((String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
xs -> [ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs | Char
x <- [Char
'a'..Char
'z'] ])) [String
""]
           in String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
             [ String
"Embedded pattern synonym used outside 'match' context."
             , String
""
             , String
"To use case statements in the embedded language the case statement must"
             , String
"be applied as an n-ary function to the 'match' operator. For single"
             , String
"argument case statements this can be done inline using LambdaCase, for"
             , String
"example:"
             , String
""
             , String
"> x & match \\case"
             , String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
">   %s%s -> ..." String
pn String
pv
             , String -> String -> String
forall r. PrintfType r => String -> r
printf String
">   _%s -> ..." (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pv Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ')
             ]

fst3 :: (a,b,c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a,b
_,c
_) = a
a

thd3 :: (a,b,c) -> c
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_,b
_,c
c) = c
c

rename :: Name -> Name
rename :: Name -> Name
rename Name
nm =
  let
      split :: String -> String -> (String, Char)
split String
acc []     = (String -> String
forall a. [a] -> [a]
reverse String
acc, Char
'\0')  -- shouldn't happen
      split String
acc [Char
l]    = (String -> String
forall a. [a] -> [a]
reverse String
acc, Char
l)
      split String
acc (Char
l:String
ls) = String -> String -> (String, Char)
split (Char
lChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
ls
      --
      nm' :: String
nm'              = Name -> String
nameBase Name
nm
      (String
base, Char
suffix)   = String -> String -> (String, Char)
split [] String
nm'
   in
   case Char
suffix of
     Char
'_' -> String -> Name
mkName String
base
     Char
_   -> String -> Name
mkName (String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")

checkExts :: [Extension] -> Q ()
checkExts :: [Extension] -> Q ()
checkExts [Extension]
req = do
  [Extension]
enabled <- Q [Extension]
extsEnabled
  let missing :: [Extension]
missing = [Extension]
req [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Extension]
enabled
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Extension] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Extension]
missing) (Q () -> Q ()) -> ([String] -> Q ()) -> [String] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> ([String] -> String) -> [String] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    ([String] -> Q ()) -> [String] -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall r. PrintfType r => String -> r
printf String
"You must enable the following language extensions to generate pattern synonyms:"
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"    {-# LANGUAGE %s #-}" (String -> String) -> (Extension -> String) -> Extension -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show) [Extension]
missing

-- A simplified version of that stolen from GHC/Utils/Encoding.hs
--
type EncodedString = String

zencode :: String -> EncodedString
zencode :: String -> String
zencode []       = []
zencode (Char
h:String
rest) = Char -> String
encode_digit Char
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
go String
rest
  where
    go :: String -> String
go []     = []
    go (Char
c:String
cs) = Char -> String
encode_ch Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
go String
cs

unencoded_char :: Char -> Bool
unencoded_char :: Char -> Bool
unencoded_char Char
'z' = Bool
False
unencoded_char Char
'Z' = Bool
False
unencoded_char Char
c   = Char -> Bool
isAlphaNum Char
c

encode_digit :: Char -> EncodedString
encode_digit :: Char -> String
encode_digit Char
c | Char -> Bool
isDigit Char
c = Char -> String
encode_as_unicode_char Char
c
               | Bool
otherwise = Char -> String
encode_ch Char
c

encode_ch :: Char -> EncodedString
encode_ch :: Char -> String
encode_ch Char
c | Char -> Bool
unencoded_char Char
c = [Char
c]     -- Common case first
encode_ch Char
'('  = String
"ZL"
encode_ch Char
')'  = String
"ZR"
encode_ch Char
'['  = String
"ZM"
encode_ch Char
']'  = String
"ZN"
encode_ch Char
':'  = String
"ZC"
encode_ch Char
'Z'  = String
"ZZ"
encode_ch Char
'z'  = String
"zz"
encode_ch Char
'&'  = String
"za"
encode_ch Char
'|'  = String
"zb"
encode_ch Char
'^'  = String
"zc"
encode_ch Char
'$'  = String
"zd"
encode_ch Char
'='  = String
"ze"
encode_ch Char
'>'  = String
"zg"
encode_ch Char
'#'  = String
"zh"
encode_ch Char
'.'  = String
"zi"
encode_ch Char
'<'  = String
"zl"
encode_ch Char
'-'  = String
"zm"
encode_ch Char
'!'  = String
"zn"
encode_ch Char
'+'  = String
"zp"
encode_ch Char
'\'' = String
"zq"
encode_ch Char
'\\' = String
"zr"
encode_ch Char
'/'  = String
"zs"
encode_ch Char
'*'  = String
"zt"
encode_ch Char
'_'  = String
"zu"
encode_ch Char
'%'  = String
"zv"
encode_ch Char
c    = Char -> String
encode_as_unicode_char Char
c

encode_as_unicode_char :: Char -> EncodedString
encode_as_unicode_char :: Char -> String
encode_as_unicode_char Char
c
  = Char
'z'
  Char -> String -> String
forall a. a -> [a] -> [a]
: if Char -> Bool
isDigit (String -> Char
forall a. HasCallStack => [a] -> a
head String
hex_str) then String
hex_str
                              else Char
'0'Char -> String -> String
forall a. a -> [a] -> [a]
:String
hex_str
  where
    hex_str :: String
hex_str = Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (Char -> Int
ord Char
c) String
"U"