{-# 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                                          hiding ( Exp, Match, match, tupP, tupE )
import Language.Haskell.TH.Extra
import Numeric
import Text.Printf
import qualified Language.Haskell.TH                                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)
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 (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
mkDataD Name
nm [TyVarBndr]
tv [Con]
cs
    NewtypeD Cxt
_ Name
nm [TyVarBndr]
tv Maybe Kind
_ Con
c  [DerivClause]
_ -> Name -> [TyVarBndr] -> Con -> DecsQ
mkNewtypeD Name
nm [TyVarBndr]
tv Con
c
    Dec
_                       -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: expected the name of a newtype or datatype"

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

mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ
mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ
mkDataD Name
tn [TyVarBndr]
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 -> DecQ
pragCompleteD [Name]
pats Maybe Name
forall a. Maybe a
Nothing
  [Dec] -> DecsQ
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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkPatterns: empty data declarations not supported"
    go [Con
c] = (Name, [Dec]) -> [(Name, [Dec])]
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] -> Con -> Q (Name, [Dec])
mkConP Name
tn [TyVarBndr]
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] -> [Cxt] -> [Cxt] -> Word8 -> Con -> Q (Name, [Dec])
mkConS Name
tn [TyVarBndr]
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 (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 (m :: * -> *) a. Monad m => a -> m a
return []
    go' [Cxt]
_ [Cxt]
_  [Word8]
_  [Con]
_  = String -> Q [(Name, [Dec])]
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 (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 (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 (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] -> Con -> Q (Name, [Dec])
mkConP :: Name -> [TyVarBndr] -> Con -> Q (Name, [Dec])
mkConP Name
tn' [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
newName String
"_x")
      [Dec]
r  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         ([Name] -> PatSynArgsQ
prefixPatSyn [Name]
xs)
                         PatSynDirQ
implBidir
                         [p| Pattern $(tupP (map varP xs)) |]
                     ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
pat, [Dec]
r)
      where
        pat :: Name
pat = Name -> Name
rename Name
cn
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         ([Name] -> PatSynArgsQ
recordPatSyn [Name]
xs)
                         PatSynDirQ
implBidir
                         [p| Pattern $(tupP (map varP xs)) |]
                     ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
pat, [Dec]
r)
      where
        pat :: Name
pat = Name -> Name
rename Name
cn
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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
newName String
"_a"
      Name
_b <- String -> Q Name
newName String
"_b"
      [Dec]
r  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         (Name -> Name -> PatSynArgsQ
infixPatSyn Name
_a Name
_b)
                         PatSynDirQ
implBidir
                         [p| Pattern $(tupP [varP _a, varP _b]) |]
                     ]
      [Dec]
r' <- case Maybe Fixity
mf of
              Maybe Fixity
Nothing -> [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
              Just Fixity
f  -> [Dec] -> DecsQ
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 (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 :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return t) |]) Cxt
fs))

mkConS :: Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec])
mkConS :: Name
-> [TyVarBndr] -> [Cxt] -> [Cxt] -> Word8 -> Con -> Q (Name, [Dec])
mkConS Name
tn' [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
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 (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 (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
newName String
"_x")
      [Dec]
r  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         ([Name] -> PatSynArgsQ
prefixPatSyn [Name]
xs)
                         ([ClauseQ] -> PatSynDirQ
explBidir [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
build)) []])
                         (PatQ -> PatQ
parensP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> PatQ -> PatQ
viewP (Name -> ExpQ
varE Name
match) [p| Just $(tupP (map varP xs)) |])
                     ]
      [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
      where
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ([t| HasCallStack |] TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         ([Name] -> PatSynArgsQ
recordPatSyn [Name]
xs)
                         ([ClauseQ] -> PatSynDirQ
explBidir [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
build)) []])
                         (PatQ -> PatQ
parensP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> PatQ -> PatQ
viewP (Name -> ExpQ
varE Name
match) [p| Just $(tupP (map varP xs)) |])
                     ]
      [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
      where
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ([t| HasCallStack |] TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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
newName String
"_a"
      Name
_b <- String -> Q Name
newName String
"_b"
      [Dec]
r  <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
patSynSigD Name
pat TypeQ
sig
                     , Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD    Name
pat
                         (Name -> Name -> PatSynArgsQ
infixPatSyn Name
_a Name
_b)
                         ([ClauseQ] -> PatSynDirQ
explBidir [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
build)) []])
                         (PatQ -> PatQ
parensP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> PatQ -> PatQ
viewP (Name -> ExpQ
varE Name
match) [p| Just $(tupP [varP _a, varP _b]) |])
                     ]
      [Dec]
r' <- case Maybe Fixity
mf of
              Maybe Fixity
Nothing -> [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r
              Just Fixity
f  -> [Dec] -> DecsQ
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 (m :: * -> *) a. Monad m => a -> m a
return [Dec]
r'
      where
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ([t| HasCallStack |] TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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
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 (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
fs) (String -> Q Name
newName String
"_x")
      let
        vs :: ExpQ
vs    = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ExpQ
es ExpQ
e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |]
              ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$  (Kind -> ExpQ) -> Cxt -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [| unExp (undef @ $(return t)) |] ) ([Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Cxt] -> [Cxt]
forall a. [a] -> [a]
reverse [Cxt]
fs0))
              [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. [a] -> [a] -> [a]
++ (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs
              [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. [a] -> [a] -> [a]
++ (Kind -> ExpQ) -> Cxt -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [| unExp (undef @ $(return t)) |] ) ([Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt]
fs1)

        tagged :: ExpQ
tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |]
        body :: ClauseQ
body   = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> [p| (Exp $(varP x)) |]) [Name]
xs) (ExpQ -> BodyQ
normalB ExpQ
tagged) []

      [Dec]
r <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
sigD Name
fun TypeQ
sig
                    , Name -> [ClauseQ] -> DecQ
funD Name
fun [ClauseQ
body]
                    ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fun, [Dec]
r)
      where
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
t TypeQ
ts -> [t| $t -> $ts |])
                       [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |]
                       ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Kind
t -> [t| Exp $(return 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
newName (String
"_match" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cn)
      Name
e       <- String -> Q Name
newName String
"_e"
      Name
x       <- String -> Q Name
newName String
"_x"
      ([PatQ]
ps,[ExpQ]
es) <- [Bool] -> ExpQ -> [PatQ] -> [ExpQ] -> Q ([PatQ], [ExpQ])
extract [Bool]
vs [| Prj PairIdxRight $(varE x) |] [] []
      Bool
unbind  <- Extension -> Q Bool
isExtEnabled Extension
RebindableSyntax
      let
        eqE :: ExpQ -> ExpQ
eqE   = if Bool
unbind then [DecQ] -> ExpQ -> ExpQ
letE [Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"==") [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE '(==))) []]] else ExpQ -> ExpQ
forall a. a -> a
id
        lhs :: PatQ
lhs   = [p| (Exp $(varP e)) |]
        body :: BodyQ
body  = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> ExpQ
eqE (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
e)
          [ PatQ -> BodyQ -> [DecQ] -> MatchQ
TH.match (Name -> [PatQ] -> PatQ
conP 'SmartExp [(Name -> [PatQ] -> PatQ
conP 'Match [[PatQ] -> PatQ
forall (t :: * -> *). Foldable t => t PatQ -> PatQ
matchP [PatQ]
ps, Name -> PatQ
varP Name
x])]) (ExpQ -> BodyQ
normalB [| Just $(tupE es)  |]) []
          , PatQ -> BodyQ -> [DecQ] -> MatchQ
TH.match (Name -> [PatQ] -> PatQ
conP 'SmartExp [(Name -> [FieldPatQ] -> PatQ
recP 'Match [])])                  (ExpQ -> BodyQ
normalB [| Nothing          |]) []
          , PatQ -> BodyQ -> [DecQ] -> MatchQ
TH.match PatQ
wildP                                                (ExpQ -> BodyQ
normalB [| error $error_msg |]) []
          ]

      [Dec]
r <- [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
sigD Name
fun TypeQ
sig
                    , Name -> [ClauseQ] -> DecQ
funD Name
fun [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
lhs] BodyQ
body []]
                    ]
      (Name, [Dec]) -> Q (Name, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fun, [Dec]
r)
      where
        sig :: TypeQ
sig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT
                ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTV [Name]
tvs)
                ([TypeQ] -> CxtQ
cxt ([t| HasCallStack |] TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
t -> [t| Elt $(varT t) |]) [Name]
tvs))
                [t| Exp $(foldl' appT (conT tn) (map varT tvs)) -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |]

        matchP :: t PatQ -> PatQ
matchP t PatQ
us = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |]
          where
            pat :: PatQ
pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |]

        extract :: [Bool] -> ExpQ -> [PatQ] -> [ExpQ] -> Q ([PatQ], [ExpQ])
extract []     ExpQ
_ [PatQ]
ps [ExpQ]
es = ([PatQ], [ExpQ]) -> Q ([PatQ], [ExpQ])
forall (m :: * -> *) a. Monad m => a -> m a
return ([PatQ]
ps, [ExpQ]
es)
        extract (Bool
u:[Bool]
us) ExpQ
x [PatQ]
ps [ExpQ]
es = do
          Name
_u <- String -> Q Name
newName String
"_u"
          let x' :: ExpQ
x' = [| Prj PairIdxLeft (SmartExp $x) |]
          if Bool -> Bool
not Bool
u
             then [Bool] -> ExpQ -> [PatQ] -> [ExpQ] -> Q ([PatQ], [ExpQ])
extract [Bool]
us ExpQ
x' (PatQ
wildPPatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
:[PatQ]
ps)  [ExpQ]
es
             else [Bool] -> ExpQ -> [PatQ] -> [ExpQ] -> Q ([PatQ], [ExpQ])
extract [Bool]
us ExpQ
x' (Name -> PatQ
varP Name
_uPatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
:[PatQ]
ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ExpQ]
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 :: ExpQ
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 (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 -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
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 (t :: * -> *) a. Foldable t => t a -> Int
length String
pn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> 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 :: (a, b, c) -> a
fst3 (a
a,b
_,c
_) = a
a

thd3 :: (a,b,c) -> c
thd3 :: (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 (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 (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. [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, Show a) => a -> String -> String
showHex (Char -> Int
ord Char
c) String
"U"