{-# 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 Type
_ [Con]
cons [DerivClause]
_) = [Con]
cons
dataDCons Dec
_                      = []


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


decTyVars :: Dec -> [TyVarBndr_ ()]
decTyVars :: Dec -> [TyVarBndr ()]
decTyVars (DataD Cxt
_ Name
_ [TyVarBndr ()]
ns Maybe Type
_ [Con]
_ [DerivClause]
_)    = [TyVarBndr ()]
ns
decTyVars (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
ns Maybe Type
_ Con
_ [DerivClause]
_) = [TyVarBndr ()]
ns
decTyVars (TySynD Name
_ [TyVarBndr ()]
ns Type
_)         = [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]
_)             = forall a. a -> Maybe a
Just Name
n
decName (DataD Cxt
_ Name
n [TyVarBndr ()]
_ Maybe Type
_ [Con]
_ [DerivClause]
_)    = forall a. a -> Maybe a
Just Name
n
decName (NewtypeD Cxt
_ Name
n [TyVarBndr ()]
_ Maybe Type
_ Con
_ [DerivClause]
_) = forall a. a -> Maybe a
Just Name
n
decName (TySynD Name
n [TyVarBndr ()]
_ Type
_)         = forall a. a -> Maybe a
Just Name
n
decName (ClassD Cxt
_ Name
n [TyVarBndr ()]
_ [FunDep]
_ [Dec]
_)     = forall a. a -> Maybe a
Just Name
n
decName (SigD Name
n Type
_)             = forall a. a -> Maybe a
Just Name
n
decName (ForeignD Foreign
fgn)         = forall a. a -> Maybe a
Just (Foreign -> Name
foreignName Foreign
fgn)
decName Dec
_                      = forall a. Maybe a
Nothing


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


cleanNames :: (Data a) => a -> a
cleanNames :: forall a. Data a => a -> a
cleanNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (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 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 :: forall a. Show a => a -> String
pretty a
a = case String -> Either String (Exp SrcSpanInfo)
parseHsExp (forall a. Show a => a -> String
show a
a) of
            Left String
_  -> []
            Right Exp SrcSpanInfo
e -> forall a. Pretty a => a -> String
prettyPrint Exp SrcSpanInfo
e


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

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


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


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

-- | @unsafeRunQ = unsafePerformIO . runQ@
unsafeRunQ :: Q a -> a
unsafeRunQ :: forall a. Q a -> a
unsafeRunQ = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"'"forall a. [a] -> [a] -> [a]
++String
s
      Just NameSpace
DataName  -> String
"'"forall a. [a] -> [a] -> [a]
++String
s
      Just NameSpace
TcClsName -> String
"''"forall a. [a] -> [a] -> [a]
++String
s
      Maybe NameSpace
_              -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(mkName \"", forall a. (a -> Bool) -> [a] -> [a]
filter (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 -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(",String
nb,String
")"]
            String
_               -> String
nb
        isSym :: Char -> Bool
        isSym :: Char -> Bool
isSym = (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 = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall (m :: * -> *). Quote m => m Type
arrowT TypeQ
a) TypeQ
b



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

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

mkVarT :: String -> TypeQ
mkVarT :: String -> TypeQ
mkVarT = forall (m :: * -> *). Quote m => Name -> m Type
varT 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) [Char
'a'..Char
'z']
              ys :: [[String]]
ys = forall a. (a -> a) -> a -> [a]
iterate (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++))) [String]
xs
           in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (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 :: 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)
_ t1
env t2
new [a2]
acc [] = (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 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'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 = forall t1 t2 a1 a2.
(t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings [(Name, Name)] -> [Name] -> Type -> (Type, [(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] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
_env [] Type
_ = 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' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
env = (Name -> Type
VarT Name
n',[(Name, Name)]
env,Name
xforall a. a -> [a] -> [a]
:[Name]
new)
 | Bool
otherwise = (Name -> Type
VarT Name
x, (Name
n,Name
x)forall a. a -> [a] -> [a]
:[(Name, Name)]
env, [Name]
new)
renameT [(Name, Name)]
env [Name]
new (ConT Name
n) = (Name -> Type
ConT (Name -> Name
normaliseName Name
n), [(Name, Name)]
env, [Name]
new)
renameT [(Name, Name)]
env [Name]
new t :: Type
t@(TupleT {}) = (Type
t,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new Type
ArrowT = (Type
ArrowT,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new Type
ListT = (Type
ListT,[(Name, Name)]
env,[Name]
new)
renameT [(Name, Name)]
env [Name]
new (AppT Type
t Type
t') = let (Type
s,[(Name, Name)]
env',[Name]
new') = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
env [Name]
new Type
t
                                  (Type
s',[(Name, Name)]
env'',[Name]
new'') = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
env' [Name]
new' Type
t'
                              in (Type -> Type -> Type
AppT Type
s Type
s', [(Name, Name)]
env'', [Name]
new'')
renameT [(Name, Name)]
env [Name]
new (ForallT [TyVarBndr Specificity]
ns Cxt
cxt Type
t) =
    let (Cxt
ns',[(Name, Name)]
env2,[Name]
new2) = [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renameTs [(Name, Name)]
env [Name]
new [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName) [TyVarBndr Specificity]
ns)
        ns'' :: [TyVarBndr Specificity]
ns'' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> TyVarBndr Specificity
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
        (Type
t',[(Name, Name)]
env4,[Name]
new4) = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
env3 [Name]
new3 Type
t
    in ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
ns'' Cxt
cxt' Type
t', [(Name, Name)]
env4, [Name]
new4)
  where
    unVarT :: Type -> TyVarBndr Specificity
unVarT (VarT Name
n) = Name -> TyVarBndr Specificity
Compat.plainTV Name
n
    unVarT Type
ty       = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"renameT: unVarT: TODO for" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty
    renamePreds :: [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renamePreds = forall t1 t2 a1 a2.
(t1 -> t2 -> a1 -> (a2, t1, t2))
-> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
renameThings [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renamePred
    renamePred :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renamePred = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT
renameT [(Name, Name)]
_ [Name]
_ Type
t = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"renameT: TODO for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t

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

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



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

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


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


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




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


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'forall a. a -> [a] -> [a]
:[Exp]
acc) Exp
e
        go [Exp]
acc Exp
e             = Exp
eforall a. a -> [a] -> [a]
:[Exp]
acc


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

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

-- | Randomly useful.
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf (Name OccName
_ (NameG NameSpace
ns PkgName
_ ModName
_)) = forall a. a -> Maybe a
Just NameSpace
ns
nameSpaceOf Name
_                       = 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 Specificity]
_ Cxt
_ Con
con) = Con -> Name
conName Con
con
conName Con
c                 = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"conName: TODO for" forall a. [a] -> [a] -> [a]
++ 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]
_) = forall a. a -> Maybe a
Just Name
n
recCName Con
_          = forall a. Maybe a
Nothing

fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI (DataConI Name
dConN Type
ty Name
_tyConN) =
  let n :: Int
n = Type -> Int
arityT Type
ty
  in forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Name]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ([Pat] -> Exp -> Exp
LamE
                    [Name -> [Pat] -> Pat
Compat.conP Name
dConN (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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [Name]
ns)
#else
                    (TupE $ fmap VarE ns)
#endif
                    ))
fromDataConI Info
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

fromTyConI :: Info -> Maybe Dec
fromTyConI :: Info -> Maybe Dec
fromTyConI (TyConI Dec
dec) = forall a. a -> Maybe a
Just Dec
dec
fromTyConI Info
_            = 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 = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ]
ps (forall (m :: * -> *). Quote m => m Exp -> m Body
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 :: forall a. Lift a => (String -> Q a) -> String -> ExpQ
toExpQ String -> Q a
parseQ = (forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q a
parseQ

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

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

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

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

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




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



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