{- Data/Singletons/Util.hs

(c) Richard Eisenberg 2013
rae@cs.brynmawr.edu

This file contains helper functions internal to the singletons package.
Users of the package should not need to consult this file.
-}

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes,
             TemplateHaskell, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, UndecidableInstances, MagicHash,
             LambdaCase, NoMonomorphismRestriction #-}

module Data.Singletons.Util where

import Prelude hiding ( exp, foldl, concat, mapM, any, pred )
import Language.Haskell.TH.Syntax hiding ( lift )
import Language.Haskell.TH.Desugar
import Data.Char
import Control.Monad hiding ( mapM )
import Control.Monad.Writer hiding ( mapM )
import Control.Monad.Reader hiding ( mapM )
import qualified Data.Map as Map
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map ( Map )
import qualified Data.Monoid as Monoid
import Data.Semigroup as Semigroup
import Data.Foldable
import Data.Functor.Identity
import Data.Traversable
import Data.Generics
import Data.Maybe
import Data.Void

-- The list of types that singletons processes by default
basicTypes :: [Name]
basicTypes :: [Name]
basicTypes = [ ''Maybe
             , ''[]
             , ''Either
             , ''NonEmpty
             , ''Void
             ] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
boundedBasicTypes

boundedBasicTypes :: [Name]
boundedBasicTypes :: [Name]
boundedBasicTypes =
            [ ''(,)
            , ''(,,)
            , ''(,,,)
            , ''(,,,,)
            , ''(,,,,,)
            , ''(,,,,,,)
            , ''Identity
            ] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
enumBasicTypes

enumBasicTypes :: [Name]
enumBasicTypes :: [Name]
enumBasicTypes = [ ''Bool, ''Ordering, ''() ]

semigroupBasicTypes :: [Name]
semigroupBasicTypes :: [Name]
semigroupBasicTypes
  = [ ''Dual
    , ''All
    , ''Any
    , ''Sum
    , ''Product
    -- , ''Endo      see https://github.com/goldfirere/singletons/issues/82
    {- , ''Alt       singletons doesn't support higher kinds :(
                     see https://github.com/goldfirere/singletons/issues/150
    -}

    , ''Min
    , ''Max
    , ''Semigroup.First
    , ''Semigroup.Last
    , ''WrappedMonoid
    ]

monoidBasicTypes :: [Name]
monoidBasicTypes :: [Name]
monoidBasicTypes
  = [ ''Monoid.First
    , ''Monoid.Last
    ]

-- like reportWarning, but generalized to any Quasi
qReportWarning :: Quasi q => String -> q ()
qReportWarning :: String -> q ()
qReportWarning = Bool -> String -> q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
False

-- like reportError, but generalized to any Quasi
qReportError :: Quasi q => String -> q ()
qReportError :: String -> q ()
qReportError = Bool -> String -> q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True

-- | Generate a new Unique
qNewUnique :: DsMonad q => q Uniq
qNewUnique :: q Uniq
qNewUnique = do
  Name _ flav :: NameFlavour
flav <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName "x"
  case NameFlavour
flav of
    NameU n :: Uniq
n -> Uniq -> q Uniq
forall (m :: * -> *) a. Monad m => a -> m a
return Uniq
n
    _       -> String -> q Uniq
forall a. HasCallStack => String -> a
error "Internal error: `qNewName` didn't return a NameU"

checkForRep :: Quasi q => [Name] -> q ()
checkForRep :: [Name] -> q ()
checkForRep names :: [Name]
names =
  Bool -> q () -> q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Rep") (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
names)
    (String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ "A data type named <<Rep>> is a special case.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "Promoting it will not work as expected.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "Please choose another name for your data type.")

checkForRepInDecls :: Quasi q => [DDec] -> q ()
checkForRepInDecls :: [DDec] -> q ()
checkForRepInDecls decls :: [DDec]
decls =
  [Name] -> q ()
forall (q :: * -> *). Quasi q => [Name] -> q ()
checkForRep ([DDec] -> [Name]
forall a. Data a => a -> [Name]
allNamesIn [DDec]
decls)

tysOfConFields :: DConFields -> [DType]
tysOfConFields :: DConFields -> [DType]
tysOfConFields (DNormalC _ stys :: [DBangType]
stys) = (DBangType -> DType) -> [DBangType] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map DBangType -> DType
forall a b. (a, b) -> b
snd [DBangType]
stys
tysOfConFields (DRecC vstys :: [DVarBangType]
vstys)   = (DVarBangType -> DType) -> [DVarBangType] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,_,ty :: DType
ty) -> DType
ty) [DVarBangType]
vstys

-- extract the name and number of arguments to a constructor
extractNameArgs :: DCon -> (Name, Int)
extractNameArgs :: DCon -> (Name, Uniq)
extractNameArgs = ([DType] -> Uniq) -> (Name, [DType]) -> (Name, Uniq)
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd [DType] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length ((Name, [DType]) -> (Name, Uniq))
-> (DCon -> (Name, [DType])) -> DCon -> (Name, Uniq)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DCon -> (Name, [DType])
extractNameTypes

-- extract the name and types of constructor arguments
extractNameTypes :: DCon -> (Name, [DType])
extractNameTypes :: DCon -> (Name, [DType])
extractNameTypes (DCon _ _ n :: Name
n fields :: DConFields
fields _) = (Name
n, DConFields -> [DType]
tysOfConFields DConFields
fields)

extractName :: DCon -> Name
extractName :: DCon -> Name
extractName (DCon _ _ n :: Name
n _ _) = Name
n

-- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?)
isInfixDataCon :: String -> Bool
isInfixDataCon :: String -> Bool
isInfixDataCon (':':_) = Bool
True
isInfixDataCon _       = Bool
False

-- | Is an identifier a legal data constructor name in Haskell? That is, is its
-- first character an uppercase letter (prefix) or a colon (infix)?
isDataConName :: Name -> Bool
isDataConName :: Name -> Bool
isDataConName n :: Name
n = let first :: Char
first = String -> Char
forall a. [a] -> a
head (Name -> String
nameBase Name
n) in Char -> Bool
isUpper Char
first Bool -> Bool -> Bool
|| Char
first Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':'

-- | Is an identifier uppercase?
--
-- Note that this will always return 'False' for infix names, since the concept
-- of upper- and lower-case doesn't make sense for non-alphabetic characters.
-- If you want to check if a name is legal as a data constructor, use the
-- 'isDataConName' function.
isUpcase :: Name -> Bool
isUpcase :: Name -> Bool
isUpcase n :: Name
n = let first :: Char
first = String -> Char
forall a. [a] -> a
head (Name -> String
nameBase Name
n) in Char -> Bool
isUpper Char
first

-- Make an identifier uppercase. If the identifier is infix, this acts as the
-- identity function.
upcase :: Name -> Name
upcase :: Name -> Name
upcase = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> Name -> String
toUpcaseStr (String, String)
noPrefix

-- make an identifier uppercase and return it as a String
toUpcaseStr :: (String, String)  -- (alpha, symb) prefixes to prepend
            -> Name -> String
toUpcaseStr :: (String, String) -> Name -> String
toUpcaseStr (alpha :: String
alpha, symb :: String
symb) n :: Name
n
  | Char -> Bool
isHsLetter Char
first
  = String
upcase_alpha

  | Bool
otherwise
  = String
upcase_symb

  where
    str :: String
str   = Name -> String
nameBase Name
n
    first :: Char
first = String -> Char
forall a. [a] -> a
head String
str

    upcase_alpha :: String
upcase_alpha = String
alpha String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char
toUpper Char
first) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
tail String
str
    upcase_symb :: String
upcase_symb = String
symb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

noPrefix :: (String, String)
noPrefix :: (String, String)
noPrefix = ("", "")

-- Put an uppercase prefix on a constructor name. Takes two prefixes:
-- one for identifiers and one for symbols.
--
-- This is different from 'prefixName' in that infix constructor names always
-- start with a colon, so we must insert the prefix after the colon in order
-- for the new name to be syntactically valid.
prefixConName :: String -> String -> Name -> Name
prefixConName :: String -> String -> Name -> Name
prefixConName pre :: String
pre tyPre :: String
tyPre n :: Name
n = case (Name -> String
nameBase Name
n) of
    (':' : rest :: String
rest) -> String -> Name
mkName (':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
tyPre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
    alpha :: String
alpha -> String -> Name
mkName (String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
alpha)

-- Put a prefix on a name. Takes two prefixes: one for identifiers
-- and one for symbols.
prefixName :: String -> String -> Name -> Name
prefixName :: String -> String -> Name -> Name
prefixName pre :: String
pre tyPre :: String
tyPre n :: Name
n =
  let str :: String
str = Name -> String
nameBase Name
n
      first :: Char
first = String -> Char
forall a. [a] -> a
head String
str in
    if Char -> Bool
isHsLetter Char
first
     then String -> Name
mkName (String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
     else String -> Name
mkName (String
tyPre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

-- Put a suffix on a name. Takes two suffixes: one for identifiers
-- and one for symbols.
suffixName :: String -> String -> Name -> Name
suffixName :: String -> String -> Name -> Name
suffixName ident :: String
ident symb :: String
symb n :: Name
n =
  let str :: String
str = Name -> String
nameBase Name
n
      first :: Char
first = String -> Char
forall a. [a] -> a
head String
str in
  if Char -> Bool
isHsLetter Char
first
  then String -> Name
mkName (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ident)
  else String -> Name
mkName (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symb)

-- convert a number into both alphanumeric and symoblic forms
uniquePrefixes :: String   -- alphanumeric prefix
               -> String   -- symbolic prefix
               -> Uniq
               -> (String, String)  -- (alphanum, symbolic)
uniquePrefixes :: String -> String -> Uniq -> (String, String)
uniquePrefixes alpha :: String
alpha symb :: String
symb n :: Uniq
n = (String
alpha String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n_str, String
symb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
convert String
n_str)
  where
    n_str :: String
n_str = Uniq -> String
forall a. Show a => a -> String
show Uniq
n

    convert :: String -> String
convert [] = []
    convert (d :: Char
d : ds :: String
ds) =
      let d' :: Char
d' = case Char
d of
                 '0' -> '!'
                 '1' -> '#'
                 '2' -> '$'
                 '3' -> '%'
                 '4' -> '&'
                 '5' -> '*'
                 '6' -> '+'
                 '7' -> '.'
                 '8' -> '/'
                 '9' -> '>'
                 _   -> String -> Char
forall a. HasCallStack => String -> a
error "non-digit in show #"
      in Char
d' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
convert String
ds

-- extract the kind from a TyVarBndr
extractTvbKind :: DTyVarBndr -> Maybe DKind
extractTvbKind :: DTyVarBndr -> Maybe DType
extractTvbKind (DPlainTV _) = Maybe DType
forall a. Maybe a
Nothing
extractTvbKind (DKindedTV _ k :: DType
k) = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
k

-- extract the name from a TyVarBndr.
extractTvbName :: DTyVarBndr -> Name
extractTvbName :: DTyVarBndr -> Name
extractTvbName (DPlainTV n :: Name
n) = Name
n
extractTvbName (DKindedTV n :: Name
n _) = Name
n

tvbToType :: DTyVarBndr -> DType
tvbToType :: DTyVarBndr -> DType
tvbToType = Name -> DType
DVarT (Name -> DType) -> (DTyVarBndr -> Name) -> DTyVarBndr -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndr -> Name
extractTvbName

inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndr
inferMaybeKindTV :: Name -> Maybe DType -> DTyVarBndr
inferMaybeKindTV n :: Name
n Nothing =  Name -> DTyVarBndr
DPlainTV Name
n
inferMaybeKindTV n :: Name
n (Just k :: DType
k) = Name -> DType -> DTyVarBndr
DKindedTV Name
n DType
k

resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind
resultSigToMaybeKind :: DFamilyResultSig -> Maybe DType
resultSigToMaybeKind DNoSig                      = Maybe DType
forall a. Maybe a
Nothing
resultSigToMaybeKind (DKindSig k :: DType
k)                = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
k
resultSigToMaybeKind (DTyVarSig (DPlainTV _))    = Maybe DType
forall a. Maybe a
Nothing
resultSigToMaybeKind (DTyVarSig (DKindedTV _ k :: DType
k)) = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
k

-- Reconstruct arrow kind from the list of kinds
ravel :: [DType] -> DType -> DType
ravel :: [DType] -> DType -> DType
ravel []    res :: DType
res  = DType
res
ravel (h :: DType
h:t :: [DType]
t) res :: DType
res = DType -> DType -> DType
DAppT (DType -> DType -> DType
DAppT DType
DArrowT DType
h) ([DType] -> DType -> DType
ravel [DType]
t DType
res)

-- count the number of arguments in a type
countArgs :: DType -> Int
countArgs :: DType -> Uniq
countArgs ty :: DType
ty = [DType] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [DType]
args
  where (_, _, args :: [DType]
args, _) = DType -> ([DTyVarBndr], [DType], [DType], DType)
unravel DType
ty

-- changes all TyVars not to be NameU's. Workaround for GHC#11812
noExactTyVars :: Data a => a -> a
noExactTyVars :: a -> a
noExactTyVars = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere forall a. Data a => a -> a
go
  where
    go :: Data a => a -> a
    go :: a -> a
go = (DTyVarBndr -> DTyVarBndr) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT DTyVarBndr -> DTyVarBndr
fix_tvb (a -> a) -> (DType -> DType) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` DType -> DType
fix_ty (a -> a) -> (InjectivityAnn -> InjectivityAnn) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` InjectivityAnn -> InjectivityAnn
fix_inj_ann

    no_exact_name :: Name -> Name
    no_exact_name :: Name -> Name
no_exact_name (Name (OccName occ :: String
occ) (NameU unique :: Uniq
unique)) = String -> Name
mkName (String
occ String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uniq -> String
forall a. Show a => a -> String
show Uniq
unique)
    no_exact_name n :: Name
n                                   = Name
n

    fix_tvb :: DTyVarBndr -> DTyVarBndr
fix_tvb (DPlainTV n :: Name
n)    = Name -> DTyVarBndr
DPlainTV (Name -> Name
no_exact_name Name
n)
    fix_tvb (DKindedTV n :: Name
n k :: DType
k) = Name -> DType -> DTyVarBndr
DKindedTV (Name -> Name
no_exact_name Name
n) DType
k

    fix_ty :: DType -> DType
fix_ty (DVarT n :: Name
n)           = Name -> DType
DVarT (Name -> Name
no_exact_name Name
n)
    fix_ty ty :: DType
ty                  = DType
ty

    fix_inj_ann :: InjectivityAnn -> InjectivityAnn
fix_inj_ann (InjectivityAnn lhs :: Name
lhs rhs :: [Name]
rhs)
      = Name -> [Name] -> InjectivityAnn
InjectivityAnn (Name -> Name
no_exact_name Name
lhs) ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
no_exact_name [Name]
rhs)

substKind :: Map Name DKind -> DKind -> DKind
substKind :: Map Name DType -> DType -> DType
substKind = Map Name DType -> DType -> DType
substType

-- | Non–capture-avoiding substitution. (If you want capture-avoiding
-- substitution, use @substTy@ from "Language.Haskell.TH.Desugar.Subst".
substType :: Map Name DType -> DType -> DType
substType :: Map Name DType -> DType -> DType
substType subst :: Map Name DType
subst ty :: DType
ty | Map Name DType -> Bool
forall k a. Map k a -> Bool
Map.null Map Name DType
subst = DType
ty
substType subst :: Map Name DType
subst (DForallT tvbs :: [DTyVarBndr]
tvbs cxt :: [DType]
cxt inner_ty :: DType
inner_ty)
  = [DTyVarBndr] -> [DType] -> DType -> DType
DForallT [DTyVarBndr]
tvbs' [DType]
cxt' DType
inner_ty'
  where
    (subst' :: Map Name DType
subst', tvbs' :: [DTyVarBndr]
tvbs') = (Map Name DType -> DTyVarBndr -> (Map Name DType, DTyVarBndr))
-> Map Name DType -> [DTyVarBndr] -> (Map Name DType, [DTyVarBndr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Map Name DType -> DTyVarBndr -> (Map Name DType, DTyVarBndr)
subst_tvb Map Name DType
subst [DTyVarBndr]
tvbs
    cxt' :: [DType]
cxt'            = (DType -> DType) -> [DType] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map (Map Name DType -> DType -> DType
substType Map Name DType
subst') [DType]
cxt
    inner_ty' :: DType
inner_ty'       = Map Name DType -> DType -> DType
substType Map Name DType
subst' DType
inner_ty
substType subst :: Map Name DType
subst (DAppT ty1 :: DType
ty1 ty2 :: DType
ty2) = Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ty1 DType -> DType -> DType
`DAppT` Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ty2
substType subst :: Map Name DType
subst (DAppKindT ty :: DType
ty ki :: DType
ki) = Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ty DType -> DType -> DType
`DAppKindT` Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ki
substType subst :: Map Name DType
subst (DSigT ty :: DType
ty ki :: DType
ki) = Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ty DType -> DType -> DType
`DSigT` Map Name DType -> DType -> DType
substType Map Name DType
subst DType
ki
substType subst :: Map Name DType
subst (DVarT n :: Name
n) =
  case Name -> Map Name DType -> Maybe DType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name DType
subst of
    Just ki :: DType
ki -> DType
ki
    Nothing -> Name -> DType
DVarT Name
n
substType _ ty :: DType
ty@(DConT {}) = DType
ty
substType _ ty :: DType
ty@(DType
DArrowT)  = DType
ty
substType _ ty :: DType
ty@(DLitT {}) = DType
ty
substType _ ty :: DType
ty@DType
DWildCardT = DType
ty

subst_tvb :: Map Name DKind -> DTyVarBndr -> (Map Name DKind, DTyVarBndr)
subst_tvb :: Map Name DType -> DTyVarBndr -> (Map Name DType, DTyVarBndr)
subst_tvb s :: Map Name DType
s tvb :: DTyVarBndr
tvb@(DPlainTV n :: Name
n) = (Name -> Map Name DType -> Map Name DType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
n Map Name DType
s, DTyVarBndr
tvb)
subst_tvb s :: Map Name DType
s (DKindedTV n :: Name
n k :: DType
k)  = (Name -> Map Name DType -> Map Name DType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
n Map Name DType
s, Name -> DType -> DTyVarBndr
DKindedTV Name
n (Map Name DType -> DType -> DType
substKind Map Name DType
s DType
k))

cuskify :: DTyVarBndr -> DTyVarBndr
cuskify :: DTyVarBndr -> DTyVarBndr
cuskify (DPlainTV tvname :: Name
tvname) = Name -> DType -> DTyVarBndr
DKindedTV Name
tvname (DType -> DTyVarBndr) -> DType -> DTyVarBndr
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
typeKindName
cuskify tvb :: DTyVarBndr
tvb               = DTyVarBndr
tvb

-- apply a type to a list of types
foldType :: DType -> [DType] -> DType
foldType :: DType -> [DType] -> DType
foldType = (DType -> DType -> DType) -> DType -> [DType] -> DType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DType -> DType -> DType
DAppT

-- apply a type to a list of type variable binders
foldTypeTvbs :: DType -> [DTyVarBndr] -> DType
foldTypeTvbs :: DType -> [DTyVarBndr] -> DType
foldTypeTvbs ty :: DType
ty = DType -> [DType] -> DType
foldType DType
ty ([DType] -> DType)
-> ([DTyVarBndr] -> [DType]) -> [DTyVarBndr] -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndr -> DType) -> [DTyVarBndr] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> DType
tvbToType

-- Construct a data type's variable binders, possibly using fresh variables
-- from the data type's kind signature.
buildDataDTvbs :: DsMonad q => [DTyVarBndr] -> Maybe DKind -> q [DTyVarBndr]
buildDataDTvbs :: [DTyVarBndr] -> Maybe DType -> q [DTyVarBndr]
buildDataDTvbs tvbs :: [DTyVarBndr]
tvbs mk :: Maybe DType
mk = do
  [DTyVarBndr]
extra_tvbs <- DType -> q [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> q [DTyVarBndr]
mkExtraDKindBinders (DType -> q [DTyVarBndr]) -> DType -> q [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$ DType -> Maybe DType -> DType
forall a. a -> Maybe a -> a
fromMaybe (Name -> DType
DConT Name
typeKindName) Maybe DType
mk
  [DTyVarBndr] -> q [DTyVarBndr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr] -> q [DTyVarBndr]) -> [DTyVarBndr] -> q [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$ [DTyVarBndr]
tvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
extra_tvbs

-- apply an expression to a list of expressions
foldExp :: DExp -> [DExp] -> DExp
foldExp :: DExp -> [DExp] -> DExp
foldExp = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE

-- is a function type?
isFunTy :: DType -> Bool
isFunTy :: DType -> Bool
isFunTy (DAppT (DAppT DArrowT _) _) = Bool
True
isFunTy (DForallT _ _ _)            = Bool
True
isFunTy _                           = Bool
False

-- choose the first non-empty list
orIfEmpty :: [a] -> [a] -> [a]
orIfEmpty :: [a] -> [a] -> [a]
orIfEmpty [] x :: [a]
x = [a]
x
orIfEmpty x :: [a]
x  _ = [a]
x

-- build a pattern match over several expressions, each with only one pattern
multiCase :: [DExp] -> [DPat] -> DExp -> DExp
multiCase :: [DExp] -> [DPat] -> DExp -> DExp
multiCase [] [] body :: DExp
body = DExp
body
multiCase scruts :: [DExp]
scruts pats :: [DPat]
pats body :: DExp
body =
  DExp -> [DMatch] -> DExp
DCaseE ([DExp] -> DExp
mkTupleDExp [DExp]
scruts) [DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats) DExp
body]

-- Make a desugar function into a TH function.
wrapDesugar :: (Desugar th ds, DsMonad q) => (th -> ds -> q ds) -> th -> q th
wrapDesugar :: (th -> ds -> q ds) -> th -> q th
wrapDesugar f :: th -> ds -> q ds
f th :: th
th = do
  ds
ds <- th -> q ds
forall th ds (q :: * -> *).
(Desugar th ds, DsMonad q) =>
th -> q ds
desugar th
th
  (ds -> th) -> q ds -> q th
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ds -> th
forall th ds. Desugar th ds => ds -> th
sweeten (q ds -> q th) -> q ds -> q th
forall a b. (a -> b) -> a -> b
$ th -> ds -> q ds
f th
th ds
ds

-- a monad transformer for writing a monoid alongside returning a Q
newtype QWithAux m q a = QWA { QWithAux m q a -> WriterT m q a
runQWA :: WriterT m q a }
  deriving ( a -> QWithAux m q b -> QWithAux m q a
(a -> b) -> QWithAux m q a -> QWithAux m q b
(forall a b. (a -> b) -> QWithAux m q a -> QWithAux m q b)
-> (forall a b. a -> QWithAux m q b -> QWithAux m q a)
-> Functor (QWithAux m q)
forall a b. a -> QWithAux m q b -> QWithAux m q a
forall a b. (a -> b) -> QWithAux m q a -> QWithAux m q b
forall m (q :: * -> *) a b.
Functor q =>
a -> QWithAux m q b -> QWithAux m q a
forall m (q :: * -> *) a b.
Functor q =>
(a -> b) -> QWithAux m q a -> QWithAux m q b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> QWithAux m q b -> QWithAux m q a
$c<$ :: forall m (q :: * -> *) a b.
Functor q =>
a -> QWithAux m q b -> QWithAux m q a
fmap :: (a -> b) -> QWithAux m q a -> QWithAux m q b
$cfmap :: forall m (q :: * -> *) a b.
Functor q =>
(a -> b) -> QWithAux m q a -> QWithAux m q b
Functor, Functor (QWithAux m q)
a -> QWithAux m q a
Functor (QWithAux m q) =>
(forall a. a -> QWithAux m q a)
-> (forall a b.
    QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b)
-> (forall a b c.
    (a -> b -> c)
    -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c)
-> (forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q b)
-> (forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q a)
-> Applicative (QWithAux m q)
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
QWithAux m q a -> QWithAux m q b -> QWithAux m q a
QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b
(a -> b -> c) -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c
forall a. a -> QWithAux m q a
forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q a
forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q b
forall a b.
QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b
forall a b c.
(a -> b -> c) -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c
forall m (q :: * -> *).
(Monoid m, Applicative q) =>
Functor (QWithAux m q)
forall m (q :: * -> *) a.
(Monoid m, Applicative q) =>
a -> QWithAux m q a
forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q a
forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b
forall m (q :: * -> *) a b c.
(Monoid m, Applicative q) =>
(a -> b -> c) -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: QWithAux m q a -> QWithAux m q b -> QWithAux m q a
$c<* :: forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q a
*> :: QWithAux m q a -> QWithAux m q b -> QWithAux m q b
$c*> :: forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
liftA2 :: (a -> b -> c) -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c
$cliftA2 :: forall m (q :: * -> *) a b c.
(Monoid m, Applicative q) =>
(a -> b -> c) -> QWithAux m q a -> QWithAux m q b -> QWithAux m q c
<*> :: QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b
$c<*> :: forall m (q :: * -> *) a b.
(Monoid m, Applicative q) =>
QWithAux m q (a -> b) -> QWithAux m q a -> QWithAux m q b
pure :: a -> QWithAux m q a
$cpure :: forall m (q :: * -> *) a.
(Monoid m, Applicative q) =>
a -> QWithAux m q a
$cp1Applicative :: forall m (q :: * -> *).
(Monoid m, Applicative q) =>
Functor (QWithAux m q)
Applicative, Applicative (QWithAux m q)
a -> QWithAux m q a
Applicative (QWithAux m q) =>
(forall a b.
 QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b)
-> (forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q b)
-> (forall a. a -> QWithAux m q a)
-> Monad (QWithAux m q)
QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
forall a. a -> QWithAux m q a
forall a b. QWithAux m q a -> QWithAux m q b -> QWithAux m q b
forall a b.
QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b
forall m (q :: * -> *).
(Monoid m, Monad q) =>
Applicative (QWithAux m q)
forall m (q :: * -> *) a.
(Monoid m, Monad q) =>
a -> QWithAux m q a
forall m (q :: * -> *) a b.
(Monoid m, Monad q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
forall m (q :: * -> *) a b.
(Monoid m, Monad q) =>
QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> QWithAux m q a
$creturn :: forall m (q :: * -> *) a.
(Monoid m, Monad q) =>
a -> QWithAux m q a
>> :: QWithAux m q a -> QWithAux m q b -> QWithAux m q b
$c>> :: forall m (q :: * -> *) a b.
(Monoid m, Monad q) =>
QWithAux m q a -> QWithAux m q b -> QWithAux m q b
>>= :: QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b
$c>>= :: forall m (q :: * -> *) a b.
(Monoid m, Monad q) =>
QWithAux m q a -> (a -> QWithAux m q b) -> QWithAux m q b
$cp1Monad :: forall m (q :: * -> *).
(Monoid m, Monad q) =>
Applicative (QWithAux m q)
Monad, m a -> QWithAux m m a
(forall (m :: * -> *) a. Monad m => m a -> QWithAux m m a)
-> MonadTrans (QWithAux m)
forall m (m :: * -> *) a.
(Monoid m, Monad m) =>
m a -> QWithAux m m a
forall (m :: * -> *) a. Monad m => m a -> QWithAux m m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> QWithAux m m a
$clift :: forall m (m :: * -> *) a.
(Monoid m, Monad m) =>
m a -> QWithAux m m a
MonadTrans
           , MonadWriter m, MonadReader r
           , Monad (QWithAux m q)
Monad (QWithAux m q) =>
(forall a. String -> QWithAux m q a) -> MonadFail (QWithAux m q)
String -> QWithAux m q a
forall a. String -> QWithAux m q a
forall m (q :: * -> *).
(Monoid m, MonadFail q) =>
Monad (QWithAux m q)
forall m (q :: * -> *) a.
(Monoid m, MonadFail q) =>
String -> QWithAux m q a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> QWithAux m q a
$cfail :: forall m (q :: * -> *) a.
(Monoid m, MonadFail q) =>
String -> QWithAux m q a
$cp1MonadFail :: forall m (q :: * -> *).
(Monoid m, MonadFail q) =>
Monad (QWithAux m q)
MonadFail, Monad (QWithAux m q)
Monad (QWithAux m q) =>
(forall a. IO a -> QWithAux m q a) -> MonadIO (QWithAux m q)
IO a -> QWithAux m q a
forall a. IO a -> QWithAux m q a
forall m (q :: * -> *).
(Monoid m, MonadIO q) =>
Monad (QWithAux m q)
forall m (q :: * -> *) a.
(Monoid m, MonadIO q) =>
IO a -> QWithAux m q a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> QWithAux m q a
$cliftIO :: forall m (q :: * -> *) a.
(Monoid m, MonadIO q) =>
IO a -> QWithAux m q a
$cp1MonadIO :: forall m (q :: * -> *).
(Monoid m, MonadIO q) =>
Monad (QWithAux m q)
MonadIO )

-- make a Quasi instance for easy lifting
instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where
  qNewName :: String -> QWithAux m q Name
qNewName          = q Name -> QWithAux m q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Name -> QWithAux m q Name)
-> (String -> q Name) -> String -> QWithAux m q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName
  qReport :: Bool -> String -> QWithAux m q ()
qReport           = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> (Bool -> String -> q ()) -> Bool -> String -> QWithAux m q ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
`comp2` Bool -> String -> q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport
  qLookupName :: Bool -> String -> QWithAux m q (Maybe Name)
qLookupName       = q (Maybe Name) -> QWithAux m q (Maybe Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q (Maybe Name) -> QWithAux m q (Maybe Name))
-> (Bool -> String -> q (Maybe Name))
-> Bool
-> String
-> QWithAux m q (Maybe Name)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
`comp2` Bool -> String -> q (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> m (Maybe Name)
qLookupName
  qReify :: Name -> QWithAux m q Info
qReify            = q Info -> QWithAux m q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Info -> QWithAux m q Info)
-> (Name -> q Info) -> Name -> QWithAux m q Info
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Name -> q Info
forall (m :: * -> *). Quasi m => Name -> m Info
qReify
  qReifyInstances :: Name -> [Type] -> QWithAux m q [Dec]
qReifyInstances   = q [Dec] -> QWithAux m q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q [Dec] -> QWithAux m q [Dec])
-> (Name -> [Type] -> q [Dec])
-> Name
-> [Type]
-> QWithAux m q [Dec]
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
`comp2` Name -> [Type] -> q [Dec]
forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances
  qLocation :: QWithAux m q Loc
qLocation         = q Loc -> QWithAux m q Loc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
  qRunIO :: IO a -> QWithAux m q a
qRunIO            = q a -> QWithAux m q a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q a -> QWithAux m q a) -> (IO a -> q a) -> IO a -> QWithAux m q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` IO a -> q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO
  qAddDependentFile :: String -> QWithAux m q ()
qAddDependentFile = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> (String -> q ()) -> String -> QWithAux m q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` String -> q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile
  qReifyRoles :: Name -> QWithAux m q [Role]
qReifyRoles       = q [Role] -> QWithAux m q [Role]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q [Role] -> QWithAux m q [Role])
-> (Name -> q [Role]) -> Name -> QWithAux m q [Role]
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Name -> q [Role]
forall (m :: * -> *). Quasi m => Name -> m [Role]
qReifyRoles
  qReifyAnnotations :: AnnLookup -> QWithAux m q [a]
qReifyAnnotations = q [a] -> QWithAux m q [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q [a] -> QWithAux m q [a])
-> (AnnLookup -> q [a]) -> AnnLookup -> QWithAux m q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` AnnLookup -> q [a]
forall (m :: * -> *) a. (Quasi m, Data a) => AnnLookup -> m [a]
qReifyAnnotations
  qReifyModule :: Module -> QWithAux m q ModuleInfo
qReifyModule      = q ModuleInfo -> QWithAux m q ModuleInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q ModuleInfo -> QWithAux m q ModuleInfo)
-> (Module -> q ModuleInfo) -> Module -> QWithAux m q ModuleInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Module -> q ModuleInfo
forall (m :: * -> *). Quasi m => Module -> m ModuleInfo
qReifyModule
  qAddTopDecls :: [Dec] -> QWithAux m q ()
qAddTopDecls      = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> ([Dec] -> q ()) -> [Dec] -> QWithAux m q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` [Dec] -> q ()
forall (m :: * -> *). Quasi m => [Dec] -> m ()
qAddTopDecls
  qAddModFinalizer :: Q () -> QWithAux m q ()
qAddModFinalizer  = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> (Q () -> q ()) -> Q () -> QWithAux m q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Q () -> q ()
forall (m :: * -> *). Quasi m => Q () -> m ()
qAddModFinalizer
  qGetQ :: QWithAux m q (Maybe a)
qGetQ             = q (Maybe a) -> QWithAux m q (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q (Maybe a)
forall (m :: * -> *) a. (Quasi m, Typeable a) => m (Maybe a)
qGetQ
  qPutQ :: a -> QWithAux m q ()
qPutQ             = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ()) -> (a -> q ()) -> a -> QWithAux m q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` a -> q ()
forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> m ()
qPutQ

  qReifyFixity :: Name -> QWithAux m q (Maybe Fixity)
qReifyFixity        = q (Maybe Fixity) -> QWithAux m q (Maybe Fixity)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q (Maybe Fixity) -> QWithAux m q (Maybe Fixity))
-> (Name -> q (Maybe Fixity))
-> Name
-> QWithAux m q (Maybe Fixity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Name -> q (Maybe Fixity)
forall (m :: * -> *). Quasi m => Name -> m (Maybe Fixity)
qReifyFixity
  qReifyConStrictness :: Name -> QWithAux m q [DecidedStrictness]
qReifyConStrictness = q [DecidedStrictness] -> QWithAux m q [DecidedStrictness]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q [DecidedStrictness] -> QWithAux m q [DecidedStrictness])
-> (Name -> q [DecidedStrictness])
-> Name
-> QWithAux m q [DecidedStrictness]
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Name -> q [DecidedStrictness]
forall (m :: * -> *). Quasi m => Name -> m [DecidedStrictness]
qReifyConStrictness
  qIsExtEnabled :: Extension -> QWithAux m q Bool
qIsExtEnabled       = q Bool -> QWithAux m q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Bool -> QWithAux m q Bool)
-> (Extension -> q Bool) -> Extension -> QWithAux m q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` Extension -> q Bool
forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled
  qExtsEnabled :: QWithAux m q [Extension]
qExtsEnabled        = q [Extension] -> QWithAux m q [Extension]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q [Extension]
forall (m :: * -> *). Quasi m => m [Extension]
qExtsEnabled
  qAddForeignFilePath :: ForeignSrcLang -> String -> QWithAux m q ()
qAddForeignFilePath = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> (ForeignSrcLang -> String -> q ())
-> ForeignSrcLang
-> String
-> QWithAux m q ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
`comp2` ForeignSrcLang -> String -> q ()
forall (m :: * -> *). Quasi m => ForeignSrcLang -> String -> m ()
qAddForeignFilePath
  qAddTempFile :: String -> QWithAux m q String
qAddTempFile        = q String -> QWithAux m q String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q String -> QWithAux m q String)
-> (String -> q String) -> String -> QWithAux m q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` String -> q String
forall (m :: * -> *). Quasi m => String -> m String
qAddTempFile
  qAddCorePlugin :: String -> QWithAux m q ()
qAddCorePlugin      = q () -> QWithAux m q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q () -> QWithAux m q ())
-> (String -> q ()) -> String -> QWithAux m q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
`comp1` String -> q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddCorePlugin

  qRecover :: QWithAux m q a -> QWithAux m q a -> QWithAux m q a
qRecover exp :: QWithAux m q a
exp handler :: QWithAux m q a
handler = do
    (result :: a
result, aux :: m
aux) <- q (a, m) -> QWithAux m q (a, m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q (a, m) -> QWithAux m q (a, m))
-> q (a, m) -> QWithAux m q (a, m)
forall a b. (a -> b) -> a -> b
$ q (a, m) -> q (a, m) -> q (a, m)
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (QWithAux m q a -> q (a, m)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair QWithAux m q a
exp) (QWithAux m q a -> q (a, m)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair QWithAux m q a
handler)
    m -> QWithAux m q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell m
aux
    a -> QWithAux m q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

instance (DsMonad q, Monoid m) => DsMonad (QWithAux m q) where
  localDeclarations :: QWithAux m q [Dec]
localDeclarations = q [Dec] -> QWithAux m q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations

-- helper functions for composition
comp1 :: (b -> c) -> (a -> b) -> a -> c
comp1 :: (b -> c) -> (a -> b) -> a -> c
comp1 = (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d
comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d
comp2 f :: c -> d
f g :: a -> b -> c
g a :: a
a b :: b
b = c -> d
f (a -> b -> c
g a
a b
b)

-- run a computation with an auxiliary monoid, discarding the monoid result
evalWithoutAux :: Quasi q => QWithAux m q a -> q a
evalWithoutAux :: QWithAux m q a -> q a
evalWithoutAux = ((a, m) -> a) -> q (a, m) -> q a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, m) -> a
forall a b. (a, b) -> a
fst (q (a, m) -> q a)
-> (QWithAux m q a -> q (a, m)) -> QWithAux m q a -> q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT m q a -> q (a, m)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT m q a -> q (a, m))
-> (QWithAux m q a -> WriterT m q a) -> QWithAux m q a -> q (a, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QWithAux m q a -> WriterT m q a
forall m (q :: * -> *) a. QWithAux m q a -> WriterT m q a
runQWA

-- run a computation with an auxiliary monoid, returning only the monoid result
evalForAux :: Quasi q => QWithAux m q a -> q m
evalForAux :: QWithAux m q a -> q m
evalForAux = WriterT m q a -> q m
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT m q a -> q m)
-> (QWithAux m q a -> WriterT m q a) -> QWithAux m q a -> q m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QWithAux m q a -> WriterT m q a
forall m (q :: * -> *) a. QWithAux m q a -> WriterT m q a
runQWA

-- run a computation with an auxiliary monoid, return both the result
-- of the computation and the monoid result
evalForPair :: QWithAux m q a -> q (a, m)
evalForPair :: QWithAux m q a -> q (a, m)
evalForPair = WriterT m q a -> q (a, m)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT m q a -> q (a, m))
-> (QWithAux m q a -> WriterT m q a) -> QWithAux m q a -> q (a, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QWithAux m q a -> WriterT m q a
forall m (q :: * -> *) a. QWithAux m q a -> WriterT m q a
runQWA

-- in a computation with an auxiliary map, add a binding to the map
addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q ()
addBinding :: k -> v -> QWithAux (Map k v) q ()
addBinding k :: k
k v :: v
v = Map k v -> QWithAux (Map k v) q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (k -> v -> Map k v
forall k a. k -> a -> Map k a
Map.singleton k
k v
v)

-- in a computation with an auxiliar list, add an element to the list
addElement :: Quasi q => elt -> QWithAux [elt] q ()
addElement :: elt -> QWithAux [elt] q ()
addElement elt :: elt
elt = [elt] -> QWithAux [elt] q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [elt
elt]

-- | Call 'lookupTypeNameWithLocals' first to ensure we have a 'Name' in the
-- type namespace, then call 'dsReify'.

-- See also Note [Using dsReifyTypeNameInfo when promoting instances]
-- in Data.Singletons.Promote.
dsReifyTypeNameInfo :: DsMonad q => Name -> q (Maybe DInfo)
dsReifyTypeNameInfo :: Name -> q (Maybe DInfo)
dsReifyTypeNameInfo ty_name :: Name
ty_name = do
  Maybe Name
mb_name <- String -> q (Maybe Name)
forall (q :: * -> *). DsMonad q => String -> q (Maybe Name)
lookupTypeNameWithLocals (Name -> String
nameBase Name
ty_name)
  case Maybe Name
mb_name of
    Just n :: Name
n  -> Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
n
    Nothing -> Maybe DInfo -> q (Maybe DInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DInfo
forall a. Maybe a
Nothing

-- lift concatMap into a monad
-- could this be more efficient?
concatMapM :: (Monad monad, Monoid monoid, Traversable t)
           => (a -> monad monoid) -> t a -> monad monoid
concatMapM :: (a -> monad monoid) -> t a -> monad monoid
concatMapM fn :: a -> monad monoid
fn list :: t a
list = do
  t monoid
bss <- (a -> monad monoid) -> t a -> monad (t monoid)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> monad monoid
fn t a
list
  monoid -> monad monoid
forall (m :: * -> *) a. Monad m => a -> m a
return (monoid -> monad monoid) -> monoid -> monad monoid
forall a b. (a -> b) -> a -> b
$ t monoid -> monoid
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold t monoid
bss

-- make a one-element list
listify :: a -> [a]
listify :: a -> [a]
listify = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])

fstOf3 :: (a,b,c) -> a
fstOf3 :: (a, b, c) -> a
fstOf3 (a :: a
a,_,_) = a
a

liftFst :: (a -> b) -> (a, c) -> (b, c)
liftFst :: (a -> b) -> (a, c) -> (b, c)
liftFst f :: a -> b
f (a :: a
a, c :: c
c) = (a -> b
f a
a, c
c)

liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd f :: a -> b
f (c :: c
c, a :: a
a) = (c
c, a -> b
f a
a)

snocView :: [a] -> ([a], a)
snocView :: [a] -> ([a], a)
snocView [] = String -> ([a], a)
forall a. HasCallStack => String -> a
error "snocView nil"
snocView [x :: a
x] = ([], a
x)
snocView (x :: a
x : xs :: [a]
xs) = ([a] -> [a]) -> ([a], a) -> ([a], a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
liftFst (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> ([a], a)
forall a. [a] -> ([a], a)
snocView [a]
xs)

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith f :: a -> Either b c
f = [b] -> [c] -> [a] -> ([b], [c])
go [] []
  where go :: [b] -> [c] -> [a] -> ([b], [c])
go bs :: [b]
bs cs :: [c]
cs []     = ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
bs, [c] -> [c]
forall a. [a] -> [a]
reverse [c]
cs)
        go bs :: [b]
bs cs :: [c]
cs (a :: a
a:as :: [a]
as) =
          case a -> Either b c
f a
a of
            Left b :: b
b  -> [b] -> [c] -> [a] -> ([b], [c])
go (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs) [c]
cs [a]
as
            Right c :: c
c -> [b] -> [c] -> [a] -> ([b], [c])
go [b]
bs (c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs) [a]
as

partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])
partitionWithM :: (a -> m (Either b c)) -> [a] -> m ([b], [c])
partitionWithM f :: a -> m (Either b c)
f = [b] -> [c] -> [a] -> m ([b], [c])
go [] []
  where go :: [b] -> [c] -> [a] -> m ([b], [c])
go bs :: [b]
bs cs :: [c]
cs []     = ([b], [c]) -> m ([b], [c])
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
bs, [c] -> [c]
forall a. [a] -> [a]
reverse [c]
cs)
        go bs :: [b]
bs cs :: [c]
cs (a :: a
a:as :: [a]
as) = do
          Either b c
fa <- a -> m (Either b c)
f a
a
          case Either b c
fa of
            Left b :: b
b  -> [b] -> [c] -> [a] -> m ([b], [c])
go (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs) [c]
cs [a]
as
            Right c :: c
c -> [b] -> [c] -> [a] -> m ([b], [c])
go [b]
bs (c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs) [a]
as

partitionLetDecs :: [DDec] -> ([DLetDec], [DDec])
partitionLetDecs :: [DDec] -> ([DLetDec], [DDec])
partitionLetDecs = (DDec -> Either DLetDec DDec) -> [DDec] -> ([DLetDec], [DDec])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (\case DLetDec ld :: DLetDec
ld -> DLetDec -> Either DLetDec DDec
forall a b. a -> Either a b
Left DLetDec
ld
                                        dec :: DDec
dec        -> DDec -> Either DLetDec DDec
forall a b. b -> Either a b
Right DDec
dec)

{-# INLINEABLE zipWith3M #-}
zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWith3M :: (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWith3M f :: a -> b -> m c
f (a :: a
a:as :: [a]
as) (b :: b
b:bs :: [b]
bs) = (:) (c -> [c] -> [c]) -> m c -> m ([c] -> [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> b -> m c
f a
a b
b m ([c] -> [c]) -> m [c] -> m [c]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> b -> m c) -> [a] -> [b] -> m [c]
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWith3M a -> b -> m c
f [a]
as [b]
bs
zipWith3M _ _ _ = [c] -> m [c]
forall (m :: * -> *) a. Monad m => a -> m a
return []

mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d])
mapAndUnzip3M :: (a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M _ []     = ([b], [c], [d]) -> m ([b], [c], [d])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[],[])
mapAndUnzip3M f :: a -> m (b, c, d)
f (x :: a
x:xs :: [a]
xs) = do
    (r1 :: b
r1,  r2 :: c
r2,  r3 :: d
r3)  <- a -> m (b, c, d)
f a
x
    (rs1 :: [b]
rs1, rs2 :: [c]
rs2, rs3 :: [d]
rs3) <- (a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M a -> m (b, c, d)
f [a]
xs
    ([b], [c], [d]) -> m ([b], [c], [d])
forall (m :: * -> *) a. Monad m => a -> m a
return (b
r1b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
rs1, c
r2c -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
rs2, d
r3d -> [d] -> [d]
forall a. a -> [a] -> [a]
:[d]
rs3)

-- is it a letter or underscore?
isHsLetter :: Char -> Bool
isHsLetter :: Char -> Bool
isHsLetter c :: Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'