{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE PatternGuards        #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | This module is a staging ground
-- for to-be-organized-and-merged-nicely code.

module Language.Haskell.Meta.Utils (
    module Language.Haskell.Meta.Utils
) where

import           Control.Monad
import           Data.Generics                  hiding (Fixity)
import           Data.List                      (findIndex)
import           Language.Haskell.Exts.Pretty   (prettyPrint)
import           Language.Haskell.Meta
import qualified Language.Haskell.Meta.THCompat as Compat (conP, plainTV)
import           Language.Haskell.TH.Lib        hiding (cxt)
import           Language.Haskell.TH.Ppr
import           Language.Haskell.TH.Syntax
import           System.IO.Unsafe               (unsafePerformIO)
import           Text.PrettyPrint

-----------------------------------------------------------------------------

dataDCons :: Dec -> [Con]
dataDCons :: Dec -> [Con]
dataDCons (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) = [Con]
cons
dataDCons Dec
_                      = []


decCons :: Dec -> [Con]
decCons :: Dec -> [Con]
decCons (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_)   = [Con]
cons
decCons (NewtypeD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ Con
con [DerivClause]
_) = [Con
con]
decCons Dec
_                        = []


decTyVars :: Dec -> [TyVarBndr_ ()]
decTyVars :: Dec -> [TyVarBndr]
decTyVars (DataD Cxt
_ Name
_ [TyVarBndr]
ns Maybe Kind
_ [Con]
_ [DerivClause]
_)    = [TyVarBndr]
ns
decTyVars (NewtypeD Cxt
_ Name
_ [TyVarBndr]
ns Maybe Kind
_ Con
_ [DerivClause]
_) = [TyVarBndr]
ns
decTyVars (TySynD Name
_ [TyVarBndr]
ns Kind
_)         = [TyVarBndr]
ns
decTyVars (ClassD Cxt
_ Name
_ [TyVarBndr]
ns [FunDep]
_ [Dec]
_)     = [TyVarBndr]
ns
decTyVars Dec
_                       = []


decName :: Dec -> Maybe Name
decName :: Dec -> Maybe Name
decName (FunD Name
n [Clause]
_)             = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (DataD Cxt
_ Name
n [TyVarBndr]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_)    = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (NewtypeD Cxt
_ Name
n [TyVarBndr]
_ Maybe Kind
_ Con
_ [DerivClause]
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (TySynD Name
n [TyVarBndr]
_ Kind
_)         = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (ClassD Cxt
_ Name
n [TyVarBndr]
_ [FunDep]
_ [Dec]
_)     = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (SigD Name
n Kind
_)             = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (ForeignD Foreign
fgn)         = Name -> Maybe Name
forall a. a -> Maybe a
Just (Foreign -> Name
foreignName Foreign
fgn)
decName Dec
_                      = Maybe Name
forall a. Maybe a
Nothing


foreignName :: Foreign -> Name
foreignName :: Foreign -> Name
foreignName (ImportF Callconv
_ Safety
_ String
_ Name
n Kind
_) = Name
n
foreignName (ExportF Callconv
_ String
_ Name
n Kind
_)   = Name
n


cleanNames :: (Data a) => a -> a
cleanNames :: a -> a
cleanNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Name -> Name
cleanName)
  where cleanName :: Name -> Name
        cleanName :: Name -> Name
cleanName Name
n
          | Name -> Bool
isNameU Name
n = Name
n
          | Bool
otherwise = (String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Name
n
        isNameU :: Name -> Bool
        isNameU :: Name -> Bool
isNameU (Name OccName
_ (NameU Uniq
_)) = Bool
True
        isNameU Name
_                  = Bool
False


-- | The type passed in must have a @Show@ instance which
--  produces a valid Haskell expression. Returns an empty
--  @String@ if this is not the case. This is not TH-specific,
--  but useful in general.
pretty :: (Show a) => a -> String
pretty :: a -> String
pretty a
a = case String -> Either String (Exp SrcSpanInfo)
parseHsExp (a -> String
forall a. Show a => a -> String
show a
a) of
            Left String
_  -> []
            Right Exp SrcSpanInfo
e -> Exp SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint Exp SrcSpanInfo
e


pp :: (Data a, Ppr a) => a -> String
pp :: a -> String
pp = a -> String
forall a. Ppr a => a -> String
pprint (a -> String) -> (a -> a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. Data a => a -> a
cleanNames

ppDoc :: (Data a, Ppr a) => a -> Doc
ppDoc :: a -> Doc
ppDoc = String -> Doc
text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. (Data a, Ppr a) => a -> String
pp


gpretty :: (Data a) => a -> String
gpretty :: a -> String
gpretty = (String -> String)
-> (Exp SrcSpanInfo -> String)
-> Either String (Exp SrcSpanInfo)
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> String
forall a b. a -> b -> a
const []) Exp SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint (Either String (Exp SrcSpanInfo) -> String)
-> (a -> Either String (Exp SrcSpanInfo)) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (Exp SrcSpanInfo)
parseHsExp (String -> Either String (Exp SrcSpanInfo))
-> (a -> String) -> a -> Either String (Exp SrcSpanInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Data a => a -> String
gshow


instance Show ExpQ where show :: ExpQ -> String
show = Exp -> String
forall a. Show a => a -> String
show (Exp -> String) -> (ExpQ -> Exp) -> ExpQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
forall a. Data a => a -> a
cleanNames (Exp -> Exp) -> (ExpQ -> Exp) -> ExpQ -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> Exp
forall a. Q a -> a
unsafeRunQ
instance Show (Q [Dec]) where show :: Q [Dec] -> String
show = [String] -> String
unlines ([String] -> String) -> (Q [Dec] -> [String]) -> Q [Dec] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> String) -> [Dec] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> String
forall a. Show a => a -> String
show (Dec -> String) -> (Dec -> Dec) -> Dec -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Dec
forall a. Data a => a -> a
cleanNames) ([Dec] -> [String]) -> (Q [Dec] -> [Dec]) -> Q [Dec] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q [Dec] -> [Dec]
forall a. Q a -> a
unsafeRunQ
instance Show DecQ where show :: DecQ -> String
show = Dec -> String
forall a. Show a => a -> String
show (Dec -> String) -> (DecQ -> Dec) -> DecQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Dec
forall a. Data a => a -> a
cleanNames (Dec -> Dec) -> (DecQ -> Dec) -> DecQ -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecQ -> Dec
forall a. Q a -> a
unsafeRunQ
instance Show TypeQ where show :: TypeQ -> String
show = Kind -> String
forall a. Show a => a -> String
show (Kind -> String) -> (TypeQ -> Kind) -> TypeQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind
forall a. Data a => a -> a
cleanNames (Kind -> Kind) -> (TypeQ -> Kind) -> TypeQ -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Kind
forall a. Q a -> a
unsafeRunQ
instance Show (Q String) where show :: Q String -> String
show = Q String -> String
forall a. Q a -> a
unsafeRunQ
instance Show (Q Doc) where show :: Q Doc -> String
show = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Q Doc -> Doc) -> Q Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Doc -> Doc
forall a. Q a -> a
unsafeRunQ

-- | @unsafeRunQ = unsafePerformIO . runQ@
unsafeRunQ :: Q a -> a
unsafeRunQ :: Q a -> a
unsafeRunQ = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (Q a -> IO a) -> Q a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> IO a
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ


nameToRawCodeStr :: Name -> String
nameToRawCodeStr :: Name -> String
nameToRawCodeStr Name
n =
  let s :: String
s = Name -> String
showNameParens Name
n
  in case Name -> Maybe NameSpace
nameSpaceOf Name
n of
      Just NameSpace
VarName   -> String
"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
      Just NameSpace
DataName  -> String
"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
      Just NameSpace
TcClsName -> String
"''"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
      Maybe NameSpace
_              -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(mkName \"", (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') String
s, String
"\")"]
  where showNameParens :: Name -> String
        showNameParens :: Name -> String
showNameParens Name
n' =
          let nb :: String
nb = Name -> String
nameBase Name
n'
          in case String
nb of
            (Char
c:String
_) | Char -> Bool
isSym Char
c -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(",String
nb,String
")"]
            String
_               -> String
nb
        isSym :: Char -> Bool
        isSym :: Char -> Bool
isSym = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"><.\\/!@#$%^&*-+?:|" :: [Char]))


-----------------------------------------------------------------------------


(|$|) :: ExpQ -> ExpQ -> ExpQ
infixr 0 |$|
ExpQ
f |$| :: ExpQ -> ExpQ -> ExpQ
|$| ExpQ
x = [|$f $x|]

(|.|) :: ExpQ -> ExpQ -> ExpQ
infixr 9 |.|
ExpQ
g |.| :: ExpQ -> ExpQ -> ExpQ
|.| ExpQ
f = [|$g . $f|]

(|->|) :: TypeQ -> TypeQ -> TypeQ
infixr 9 |->|
TypeQ
a |->| :: TypeQ -> TypeQ -> TypeQ
|->| TypeQ
b = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
a) TypeQ
b



unForall :: Type -> Type
unForall :: Kind -> Kind
unForall (ForallT [TyVarBndr]
_ Cxt
_ Kind
t) = Kind
t
unForall Kind
t               = Kind
t

functionT :: [TypeQ] -> TypeQ
functionT :: [TypeQ] -> TypeQ
functionT = (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 TypeQ -> TypeQ -> TypeQ
(|->|)

mkVarT :: String -> TypeQ
mkVarT :: String -> TypeQ
mkVarT = Name -> TypeQ
varT (Name -> TypeQ) -> (String -> Name) -> String -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName


-- | Infinite list of names composed of lowercase letters
myNames :: [Name]
myNames :: [Name]
myNames = let xs :: [String]
xs = (Char -> String) -> String -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) [Char
'a'..Char
'z']
              ys :: [[String]]
ys = ([String] -> [String]) -> [String] -> [[String]]
forall a. (a -> a) -> a -> [a]
iterate (([String] -> [String] -> [String]) -> [String] -> [String]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++))) [String]
xs
           in (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
ys)

-- | Generalisation of renameTs
renameThings :: (t1 -> t2 -> a1 -> (a2, t1, t2))
             -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings :: (t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
_ t1
env t2
new [a2]
acc [] = ([a2] -> [a2]
forall a. [a] -> [a]
reverse [a2]
acc, t1
env, t2
new)
renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
f t1
env t2
new [a2]
acc (a1
t:[a1]
ts) =
  let (a2
t', t1
env', t2
new') = t1 -> t2 -> a1 -> (a2, t1, t2)
f t1
env t2
new a1
t
  in (t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
forall t1 t2 a1 a2.
(t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings t1 -> t2 -> a1 -> (a2, t1, t2)
f t1
env' t2
new' (a2
t'a2 -> [a2] -> [a2]
forall a. a -> [a] -> [a]
:[a2]
acc) [a1]
ts

-- | renameT applied to a list of types
renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type]
  -> ([Type], [(Name,Name)], [Name])
renameTs :: [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renameTs = ([(Name, Name)]
 -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name]))
-> [(Name, Name)]
-> [Name]
-> Cxt
-> Cxt
-> (Cxt, [(Name, Name)], [Name])
forall t1 t2 a1 a2.
(t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT

-- | Rename type variables in the Type according to the given association
-- list. Normalise constructor names (remove qualification, etc.)
-- If a name is not found in the association list, replace it with one from
-- the fresh names list, and add this translation to the returned list.
-- The fresh names list should be infinite; myNames is a good example.
renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])
renameT :: [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT [(Name, Name)]
_env [] Kind
_ = String -> (Kind, [(Name, Name)], [Name])
forall a. HasCallStack => String -> a
error String
"renameT: ran out of names!"
renameT [(Name, Name)]
env (Name
x:[Name]
new) (VarT Name
n)
 | Just Name
n' <- Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
env = (Name -> Kind
VarT Name
n',[(Name, Name)]
env,Name
xName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
new)
 | Bool
otherwise = (Name -> Kind
VarT Name
x, (Name
n,Name
x)(Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
:[(Name, Name)]
env, [Name]
new)
renameT [(Name, Name)]
env [Name]
new (ConT Name
n) = (Name -> Kind
ConT (Name -> Name
normaliseName Name
n), [(Name, Name)]
env, [Name]
new)
renameT [(Name, Name)]
env [Name]
new t :: Kind
t@(TupleT {}) = (Kind
t,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new Kind
ArrowT = (Kind
ArrowT,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new Kind
ListT = (Kind
ListT,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new (AppT Kind
t Kind
t') = let (Kind
s,[(Name, Name)]
env',[Name]
new') = [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT [(Name, Name)]
env [Name]
new Kind
t
                                  (Kind
s',[(Name, Name)]
env'',[Name]
new'') = [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT [(Name, Name)]
env' [Name]
new' Kind
t'
                              in (Kind -> Kind -> Kind
AppT Kind
s Kind
s', [(Name, Name)]
env'', [Name]
new'')
renameT [(Name, Name)]
env [Name]
new (ForallT [TyVarBndr]
ns Cxt
cxt Kind
t) =
    let (Cxt
ns',[(Name, Name)]
env2,[Name]
new2) = [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renameTs [(Name, Name)]
env [Name]
new [] ((TyVarBndr -> Kind) -> [TyVarBndr] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Kind
VarT (Name -> Kind) -> (TyVarBndr -> Name) -> TyVarBndr -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
forall a. ToName a => a -> Name
toName) [TyVarBndr]
ns)
        ns'' :: [TyVarBndr]
ns'' = (Kind -> TyVarBndr) -> Cxt -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Kind -> TyVarBndr
unVarT Cxt
ns'
        (Cxt
cxt',[(Name, Name)]
env3,[Name]
new3) = [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renamePreds [(Name, Name)]
env2 [Name]
new2 [] Cxt
cxt
        (Kind
t',[(Name, Name)]
env4,[Name]
new4) = [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT [(Name, Name)]
env3 [Name]
new3 Kind
t
    in ([TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
ns'' Cxt
cxt' Kind
t', [(Name, Name)]
env4, [Name]
new4)
  where
    unVarT :: Kind -> TyVarBndr
unVarT (VarT Name
n) = Name -> TyVarBndr
Compat.plainTV Name
n
    unVarT Kind
ty       = String -> TyVarBndr
forall a. HasCallStack => String -> a
error (String -> TyVarBndr) -> String -> TyVarBndr
forall a b. (a -> b) -> a -> b
$ String
"renameT: unVarT: TODO for" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty
    renamePreds :: [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renamePreds = ([(Name, Name)]
 -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name]))
-> [(Name, Name)]
-> [Name]
-> Cxt
-> Cxt
-> (Cxt, [(Name, Name)], [Name])
forall t1 t2 a1 a2.
(t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renamePred
    renamePred :: [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renamePred = [(Name, Name)] -> [Name] -> Kind -> (Kind, [(Name, Name)], [Name])
renameT
renameT [(Name, Name)]
_ [Name]
_ Kind
t = String -> (Kind, [(Name, Name)], [Name])
forall a. HasCallStack => String -> a
error (String -> (Kind, [(Name, Name)], [Name]))
-> String -> (Kind, [(Name, Name)], [Name])
forall a b. (a -> b) -> a -> b
$ String
"renameT: TODO for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
t

-- | Remove qualification, etc.
normaliseName :: Name -> Name
normaliseName :: Name -> Name
normaliseName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

applyT :: Type -> Type -> Type
applyT :: Kind -> Kind -> Kind
applyT (ForallT [] Cxt
_ Kind
t) Kind
t' = Kind
t Kind -> Kind -> Kind
`AppT` Kind
t'
applyT (ForallT (TyVarBndr
n:[TyVarBndr]
ns) Cxt
cxt Kind
t) Kind
t' = [TyVarBndr] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr]
ns Cxt
cxt
  ([(Name, Kind)] -> [Name] -> Kind -> Kind
substT [(TyVarBndr -> Name
forall a. ToName a => a -> Name
toName TyVarBndr
n,Kind
t')] ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Name
forall a. ToName a => a -> Name
toName [TyVarBndr]
ns) Kind
t)
applyT Kind
t Kind
t' = Kind
t Kind -> Kind -> Kind
`AppT` Kind
t'



substT :: [(Name, Type)] -> [Name] -> Type -> Type
substT :: [(Name, Kind)] -> [Name] -> Kind -> Kind
substT [(Name, Kind)]
env [Name]
bnd (ForallT [TyVarBndr]
ns Cxt
_ Kind
t) = [(Name, Kind)] -> [Name] -> Kind -> Kind
substT [(Name, Kind)]
env ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Name
forall a. ToName a => a -> Name
toName [TyVarBndr]
ns[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Name]
bnd) Kind
t
substT [(Name, Kind)]
env [Name]
bnd t :: Kind
t@(VarT Name
n)
  | Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
bnd = Kind
t
  | Bool
otherwise = Kind -> (Kind -> Kind) -> Maybe Kind -> Kind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Kind
t Kind -> Kind
forall a. a -> a
id (Name -> [(Name, Kind)] -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Kind)]
env)
substT [(Name, Kind)]
env [Name]
bnd (AppT Kind
t Kind
t') = Kind -> Kind -> Kind
AppT ([(Name, Kind)] -> [Name] -> Kind -> Kind
substT [(Name, Kind)]
env [Name]
bnd Kind
t)
                                  ([(Name, Kind)] -> [Name] -> Kind -> Kind
substT [(Name, Kind)]
env [Name]
bnd Kind
t')
substT [(Name, Kind)]
_ [Name]
_ Kind
t = Kind
t





splitCon :: Con -> (Name,[Type])
splitCon :: Con -> (Name, Cxt)
splitCon Con
c = (Con -> Name
conName Con
c, Con -> Cxt
conTypes Con
c)


strictTypeTy :: StrictType -> Type
strictTypeTy :: StrictType -> Kind
strictTypeTy (Bang
_,Kind
t) = Kind
t

varStrictTypeTy :: VarStrictType -> Type
varStrictTypeTy :: VarStrictType -> Kind
varStrictTypeTy (Name
_,Bang
_,Kind
t) = Kind
t


conTypes :: Con -> [Type]
conTypes :: Con -> Cxt
conTypes (NormalC Name
_ [StrictType]
sts) = (StrictType -> Kind) -> [StrictType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Kind
strictTypeTy [StrictType]
sts
conTypes (RecC    Name
_ [VarStrictType]
vts) = (VarStrictType -> Kind) -> [VarStrictType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarStrictType -> Kind
varStrictTypeTy [VarStrictType]
vts
conTypes (InfixC StrictType
t Name
_ StrictType
t') = (StrictType -> Kind) -> [StrictType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Kind
strictTypeTy [StrictType
t,StrictType
t']
conTypes (ForallC [TyVarBndr]
_ Cxt
_ Con
c) = Con -> Cxt
conTypes Con
c
conTypes Con
c               = String -> Cxt
forall a. HasCallStack => String -> a
error (String -> Cxt) -> String -> Cxt
forall a b. (a -> b) -> a -> b
$ String
"conTypes: TODO for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
-- TODO
            -- (GadtC _ _ _)
            -- (RecGadtC _ _ _)


conToConType :: Type -> Con -> Type
conToConType :: Kind -> Con -> Kind
conToConType Kind
ofType Con
con = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Kind
a Kind
b -> Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT Kind
a) Kind
b) Kind
ofType (Con -> Cxt
conTypes Con
con)




unwindT :: Type -> [Type]
unwindT :: Kind -> Cxt
unwindT = Kind -> Cxt
go
  where go :: Type -> [Type]
        go :: Kind -> Cxt
go (ForallT [TyVarBndr]
_ Cxt
_ Kind
t)           = Kind -> Cxt
go Kind
t
        go (AppT (AppT Kind
ArrowT Kind
t) Kind
t') = Kind
t Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Kind -> Cxt
go Kind
t'
        go Kind
_                         = []


unwindE :: Exp -> [Exp]
unwindE :: Exp -> [Exp]
unwindE = [Exp] -> Exp -> [Exp]
go []
  where go :: [Exp] -> Exp -> [Exp]
go [Exp]
acc (Exp
e `AppE` Exp
e') = [Exp] -> Exp -> [Exp]
go (Exp
e'Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
acc) Exp
e
        go [Exp]
acc Exp
e             = Exp
eExp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
acc


-- | The arity of a Type.
arityT :: Type -> Int
arityT :: Kind -> Int
arityT = Int -> Kind -> Int
go Int
0
  where go :: Int -> Type -> Int
        go :: Int -> Kind -> Int
go Int
n (ForallT [TyVarBndr]
_ Cxt
_ Kind
t) = Int -> Kind -> Int
go Int
n Kind
t
        go Int
n (AppT (AppT Kind
ArrowT Kind
_) Kind
t) =
          let n' :: Int
n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in Int
n' Int -> Int -> Int
`seq` Int -> Kind -> Int
go Int
n' Kind
t
        go Int
n Kind
_ = Int
n

typeToName :: Type -> Maybe Name
typeToName :: Kind -> Maybe Name
typeToName Kind
t
  | ConT Name
n <- Kind
t = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  | Kind
ArrowT <- Kind
t = Name -> Maybe Name
forall a. a -> Maybe a
Just ''(->)
  | Kind
ListT  <- Kind
t = Name -> Maybe Name
forall a. a -> Maybe a
Just ''[]
  | TupleT Int
n <- Kind
t = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
n
  | ForallT [TyVarBndr]
_ Cxt
_ Kind
t' <- Kind
t = Kind -> Maybe Name
typeToName Kind
t'
  | Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing

-- | Randomly useful.
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf (Name OccName
_ (NameG NameSpace
ns PkgName
_ ModName
_)) = NameSpace -> Maybe NameSpace
forall a. a -> Maybe a
Just NameSpace
ns
nameSpaceOf Name
_                       = Maybe NameSpace
forall a. Maybe a
Nothing

conName :: Con -> Name
conName :: Con -> Name
conName (RecC Name
n [VarStrictType]
_)        = Name
n
conName (NormalC Name
n [StrictType]
_)     = Name
n
conName (InfixC StrictType
_ Name
n StrictType
_)    = Name
n
conName (ForallC [TyVarBndr]
_ Cxt
_ Con
con) = Con -> Name
conName Con
con
conName Con
c                 = String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"conName: TODO for" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
-- TODO
            -- (GadtC _ _ _)
            -- (RecGadtC _ _ _)

recCName :: Con -> Maybe Name
recCName :: Con -> Maybe Name
recCName (RecC Name
n [VarStrictType]
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
recCName Con
_          = Maybe Name
forall a. Maybe a
Nothing

fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI (DataConI Name
dConN Kind
ty Name
_tyConN) =
  let n :: Int
n = Kind -> Int
arityT Kind
ty
  in Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
"a")
      Q [Name] -> ([Name] -> Q (Maybe Exp)) -> Q (Maybe Exp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
ns -> Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Maybe Exp
forall a. a -> Maybe a
Just ([Pat] -> Exp -> Exp
LamE
                    [Name -> [Pat] -> Pat
Compat.conP Name
dConN ((Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
ns)]
#if MIN_VERSION_template_haskell(2,16,0)
                    ([Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
ns)
#else
                    (TupE $ fmap VarE ns)
#endif
                    ))
fromDataConI Info
_ = Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing

fromTyConI :: Info -> Maybe Dec
fromTyConI :: Info -> Maybe Dec
fromTyConI (TyConI Dec
dec) = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
dec
fromTyConI Info
_            = Maybe Dec
forall a. Maybe a
Nothing

mkFunD :: Name -> [Pat] -> Exp -> Dec
mkFunD :: Name -> [Pat] -> Exp -> Dec
mkFunD Name
f [Pat]
xs Exp
e = Name -> [Clause] -> Dec
FunD Name
f [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
xs (Exp -> Body
NormalB Exp
e) []]

mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ
mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ
mkClauseQ [PatQ]
ps ExpQ
e = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
ps (ExpQ -> BodyQ
normalB ExpQ
e) []

-----------------------------------------------------------------------------

-- | The strategy for producing QuasiQuoters which
--  this datatype aims to facilitate is as follows.
--  Given a collection of datatypes which make up
--  the to-be-quasiquoted languages AST, make each
--  type in this collection an instance of at least
--  @Show@ and @Lift@. Now, assuming @parsePat@ and
--  @parseExp@, both of type @String -> Q a@ (where @a@
--  is the top level type of the AST), are the pair of
--  functions you wish to use for parsing in pattern and
--  expression context respectively, put them inside
--  a @Quoter@ datatype and pass this to quasify.
{-
data Quoter a = Quoter
  { expQ :: (Lift a) => String -> Q a
  , patQ :: (Show a) => String -> Q a }

quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter
quasify q = QuasiQuoter
              (toExpQ (expQ q))
              (toPatQ (patQ q))
              -}

toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ)
toExpQ :: (String -> Q a) -> String -> ExpQ
toExpQ String -> Q a
parseQ = (a -> ExpQ
forall t. Lift t => t -> ExpQ
lift (a -> ExpQ) -> Q a -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Q a -> ExpQ) -> (String -> Q a) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q a
parseQ

toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ)
toPatQ :: (String -> Q a) -> String -> PatQ
toPatQ String -> Q a
parseQ = (a -> PatQ
forall a. Show a => a -> PatQ
showToPatQ (a -> PatQ) -> Q a -> PatQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Q a -> PatQ) -> (String -> Q a) -> String -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q a
parseQ

showToPatQ :: (Show a) => a -> PatQ
showToPatQ :: a -> PatQ
showToPatQ = (String -> PatQ) -> (Pat -> PatQ) -> Either String Pat -> PatQ
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> PatQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Pat -> PatQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Pat -> PatQ)
-> (a -> Either String Pat) -> a -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Pat
parsePat (String -> Either String Pat)
-> (a -> String) -> a -> Either String Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-----------------------------------------------------------------------------

eitherQ :: (e -> String) -> Either e a -> Q a
eitherQ :: (e -> String) -> Either e a -> Q a
eitherQ e -> String
toStr = (e -> Q a) -> (a -> Q a) -> Either e a -> Q a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> (e -> String) -> e -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
toStr) a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return

-----------------------------------------------------------------------------




normalizeT :: (Data a) => a -> a
normalizeT :: a -> a
normalizeT = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Kind -> Kind) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Kind -> Kind
go)
  where go :: Type -> Type
        go :: Kind -> Kind
go (ConT Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = Kind
ListT
        go (AppT (TupleT Int
1) Kind
t) = Kind
t
        go (ConT Name
n)
          | Just Int
m <- (Name -> Bool) -> [Name] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n) [Name]
tupleNames = Int -> Kind
TupleT (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
         where
          tupleNames :: [Name]
tupleNames = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
tupleTypeName [Int
2 .. Int
64]
        go Kind
t = Kind
t



-----------------------------------------------------------------------------