{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
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 Language.Haskell.TH.Lib hiding (cxt)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
import System.IO.Unsafe (unsafePerformIO)
import Text.PrettyPrint
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 n :: 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 _ (NameU _)) = Bool
True
isNameU _ = Bool
False
pretty :: (Show a) => a -> String
pretty :: a -> String
pretty a :: a
a = case String -> Either String (Exp SrcSpanInfo)
parseHsExp (a -> String
forall a. Show a => a -> String
show a
a) of
Left _ -> []
Right e :: 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 = Type -> String
forall a. Show a => a -> String
show (Type -> String) -> (TypeQ -> Type) -> TypeQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
forall a. Data a => a -> a
cleanNames (Type -> Type) -> (TypeQ -> Type) -> TypeQ -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Type
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 :: 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 n :: Name
n =
let s :: String
s = Name -> String
showNameParens Name
n
in case Name -> Maybe NameSpace
nameSpaceOf Name
n of
Just VarName -> "'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
Just DataName -> "'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
Just TcClsName -> "''"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
_ -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["(mkName \"", (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='"') String
s, "\")"]
where showNameParens :: Name -> String
showNameParens :: Name -> String
showNameParens n' :: Name
n' =
let nb :: String
nb = Name -> String
nameBase Name
n'
in case String
nb of
(c :: Char
c:_) | Char -> Bool
isSym Char
c -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["(",String
nb,")"]
_ -> String
nb
isSym :: Char -> Bool
isSym :: Char -> Bool
isSym = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ("><.\\/!@#$%^&*-+?:|" :: [Char]))
(|$|) :: ExpQ -> ExpQ -> ExpQ
infixr 0 |$|
f :: ExpQ
f |$| :: ExpQ -> ExpQ -> ExpQ
|$| x :: ExpQ
x = [|$f $x|]
(|.|) :: ExpQ -> ExpQ -> ExpQ
infixr 9 |.|
g :: ExpQ
g |.| :: ExpQ -> ExpQ -> ExpQ
|.| f :: ExpQ
f = [|$g . $f|]
(|->|) :: TypeQ -> TypeQ -> TypeQ
infixr 9 |->|
a :: TypeQ
a |->| :: TypeQ -> TypeQ -> TypeQ
|->| b :: TypeQ
b = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
a) TypeQ
b
unForall :: Type -> Type
unForall :: Type -> Type
unForall (ForallT _ _ t :: Type
t) = Type
t
unForall t :: Type
t = Type
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
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]
:[]) ['a'..'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)
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 _ env :: t1
env new :: t2
new acc :: [a2]
acc [] = ([a2] -> [a2]
forall a. [a] -> [a]
reverse [a2]
acc, t1
env, t2
new)
renameThings f :: t1 -> t2 -> a1 -> (a2, t1, t2)
f env :: t1
env new :: t2
new acc :: [a2]
acc (t :: a1
t:ts :: [a1]
ts) =
let (t' :: a2
t', env' :: t1
env', new' :: 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
renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type]
-> ([Type], [(Name,Name)], [Name])
renameTs :: [(Name, Name)]
-> [Name] -> [Type] -> [Type] -> ([Type], [(Name, Name)], [Name])
renameTs = ([(Name, Name)]
-> [Name] -> Type -> (Type, [(Name, Name)], [Name]))
-> [(Name, Name)]
-> [Name]
-> [Type]
-> [Type]
-> ([Type], [(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] -> Type -> (Type, [(Name, Name)], [Name])
renameT
renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])
renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT _env :: [(Name, Name)]
_env [] _ = String -> (Type, [(Name, Name)], [Name])
forall a. HasCallStack => String -> a
error "renameT: ran out of names!"
renameT env :: [(Name, Name)]
env (x :: Name
x:new :: [Name]
new) (VarT n :: Name
n)
| Just n' :: Name
n' <- Name -> [(Name, Name)] -> Maybe Name
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
xName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
new)
| Bool
otherwise = (Name -> Type
VarT Name
x, (Name
n,Name
x)(Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
:[(Name, Name)]
env, [Name]
new)
renameT env :: [(Name, Name)]
env new :: [Name]
new (ConT n :: Name
n) = (Name -> Type
ConT (Name -> Name
normaliseName Name
n), [(Name, Name)]
env, [Name]
new)
renameT env :: [(Name, Name)]
env new :: [Name]
new t :: Type
t@(TupleT {}) = (Type
t,[(Name, Name)]
env,[Name]
new)
renameT env :: [(Name, Name)]
env new :: [Name]
new ArrowT = (Type
ArrowT,[(Name, Name)]
env,[Name]
new)
renameT env :: [(Name, Name)]
env new :: [Name]
new ListT = (Type
ListT,[(Name, Name)]
env,[Name]
new)
renameT env :: [(Name, Name)]
env new :: [Name]
new (AppT t :: Type
t t' :: Type
t') = let (s :: Type
s,env' :: [(Name, Name)]
env',new' :: [Name]
new') = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
env [Name]
new Type
t
(s' :: Type
s',env'' :: [(Name, Name)]
env'',new'' :: [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 env :: [(Name, Name)]
env new :: [Name]
new (ForallT ns :: [TyVarBndr]
ns cxt :: [Type]
cxt t :: Type
t) =
let (ns' :: [Type]
ns',env2 :: [(Name, Name)]
env2,new2 :: [Name]
new2) = [(Name, Name)]
-> [Name] -> [Type] -> [Type] -> ([Type], [(Name, Name)], [Name])
renameTs [(Name, Name)]
env [Name]
new [] ((TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
forall a. ToName a => a -> Name
toName) [TyVarBndr]
ns)
ns'' :: [TyVarBndr]
ns'' = (Type -> TyVarBndr) -> [Type] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> TyVarBndr
unVarT [Type]
ns'
(cxt' :: [Type]
cxt',env3 :: [(Name, Name)]
env3,new3 :: [Name]
new3) = [(Name, Name)]
-> [Name] -> [Type] -> [Type] -> ([Type], [(Name, Name)], [Name])
renamePreds [(Name, Name)]
env2 [Name]
new2 [] [Type]
cxt
(t' :: Type
t',env4 :: [(Name, Name)]
env4,new4 :: [Name]
new4) = [(Name, Name)] -> [Name] -> Type -> (Type, [(Name, Name)], [Name])
renameT [(Name, Name)]
env3 [Name]
new3 Type
t
in ([TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
ns'' [Type]
cxt' Type
t', [(Name, Name)]
env4, [Name]
new4)
where
unVarT :: Type -> TyVarBndr
unVarT (VarT n :: Name
n) = Name -> TyVarBndr
PlainTV Name
n
unVarT ty :: Type
ty = String -> TyVarBndr
forall a. HasCallStack => String -> a
error (String -> TyVarBndr) -> String -> TyVarBndr
forall a b. (a -> b) -> a -> b
$ "renameT: unVarT: TODO for" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty
renamePreds :: [(Name, Name)]
-> [Name] -> [Type] -> [Type] -> ([Type], [(Name, Name)], [Name])
renamePreds = ([(Name, Name)]
-> [Name] -> Type -> (Type, [(Name, Name)], [Name]))
-> [(Name, Name)]
-> [Name]
-> [Type]
-> [Type]
-> ([Type], [(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] -> 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 _ _ t :: Type
t = String -> (Type, [(Name, Name)], [Name])
forall a. HasCallStack => String -> a
error (String -> (Type, [(Name, Name)], [Name]))
-> String -> (Type, [(Name, Name)], [Name])
forall a b. (a -> b) -> a -> b
$ "renameT: TODO for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
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 :: Type -> Type -> Type
applyT (ForallT [] _ t :: Type
t) t' :: Type
t' = Type
t Type -> Type -> Type
`AppT` Type
t'
applyT (ForallT (n :: TyVarBndr
n:ns :: [TyVarBndr]
ns) cxt :: [Type]
cxt t :: Type
t) t' :: Type
t' = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
ns [Type]
cxt
([(Name, Type)] -> [Name] -> Type -> Type
substT [(TyVarBndr -> Name
forall a. ToName a => a -> Name
toName TyVarBndr
n,Type
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) Type
t)
applyT t :: Type
t t' :: Type
t' = Type
t Type -> Type -> Type
`AppT` Type
t'
substT :: [(Name, Type)] -> [Name] -> Type -> Type
substT :: [(Name, Type)] -> [Name] -> Type -> Type
substT env :: [(Name, Type)]
env bnd :: [Name]
bnd (ForallT ns :: [TyVarBndr]
ns _ t :: Type
t) = [(Name, Type)] -> [Name] -> Type -> Type
substT [(Name, Type)]
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) Type
t
substT env :: [(Name, Type)]
env bnd :: [Name]
bnd t :: Type
t@(VarT n :: Name
n)
| Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
bnd = Type
t
| Bool
otherwise = Type -> (Type -> Type) -> Maybe Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type
t Type -> Type
forall a. a -> a
id (Name -> [(Name, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Type)]
env)
substT env :: [(Name, Type)]
env bnd :: [Name]
bnd (AppT t :: Type
t 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 _ _ t :: Type
t = Type
t
splitCon :: Con -> (Name,[Type])
splitCon :: Con -> (Name, [Type])
splitCon c :: Con
c = (Con -> Name
conName Con
c, Con -> [Type]
conTypes Con
c)
strictTypeTy :: StrictType -> Type
strictTypeTy :: StrictType -> Type
strictTypeTy (_,t :: Type
t) = Type
t
varStrictTypeTy :: VarStrictType -> Type
varStrictTypeTy :: VarStrictType -> Type
varStrictTypeTy (_,_,t :: Type
t) = Type
t
conTypes :: Con -> [Type]
conTypes :: Con -> [Type]
conTypes (NormalC _ sts :: [StrictType]
sts) = (StrictType -> Type) -> [StrictType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Type
strictTypeTy [StrictType]
sts
conTypes (RecC _ vts :: [VarStrictType]
vts) = (VarStrictType -> Type) -> [VarStrictType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarStrictType -> Type
varStrictTypeTy [VarStrictType]
vts
conTypes (InfixC t :: StrictType
t _ t' :: StrictType
t') = (StrictType -> Type) -> [StrictType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Type
strictTypeTy [StrictType
t,StrictType
t']
conTypes (ForallC _ _ c :: Con
c) = Con -> [Type]
conTypes Con
c
conTypes c :: Con
c = String -> [Type]
forall a. HasCallStack => String -> a
error (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ "conTypes: TODO for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
conToConType :: Type -> Con -> Type
conToConType :: Type -> Con -> Type
conToConType ofType :: Type
ofType con :: Con
con = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: Type
a b :: Type
b -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
a) Type
b) Type
ofType (Con -> [Type]
conTypes Con
con)
decCons :: Dec -> [Con]
#if MIN_VERSION_template_haskell(2,11,0)
decCons :: Dec -> [Con]
decCons (DataD _ _ _ _ cons :: [Con]
cons _) = [Con]
cons
decCons (NewtypeD _ _ _ _ con :: Con
con _) = [Con
con]
#else
decCons (DataD _ _ _ cons _) = cons
decCons (NewtypeD _ _ _ con _) = [con]
#endif
decCons _ = []
decTyVars :: Dec -> [TyVarBndr]
#if MIN_VERSION_template_haskell(2,11,0)
decTyVars :: Dec -> [TyVarBndr]
decTyVars (DataD _ _ ns :: [TyVarBndr]
ns _ _ _) = [TyVarBndr]
ns
decTyVars (NewtypeD _ _ ns :: [TyVarBndr]
ns _ _ _) = [TyVarBndr]
ns
#else
decTyVars (DataD _ _ ns _ _) = ns
decTyVars (NewtypeD _ _ ns _ _) = ns
#endif
decTyVars (TySynD _ ns :: [TyVarBndr]
ns _) = [TyVarBndr]
ns
decTyVars (ClassD _ _ ns :: [TyVarBndr]
ns _ _) = [TyVarBndr]
ns
decTyVars _ = []
decName :: Dec -> Maybe Name
decName :: Dec -> Maybe Name
decName (FunD n :: Name
n _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
#if MIN_VERSION_template_haskell(2,11,0)
decName (DataD _ n :: Name
n _ _ _ _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (NewtypeD _ n :: Name
n _ _ _ _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
#else
decName (DataD _ n _ _ _) = Just n
decName (NewtypeD _ n _ _ _) = Just n
#endif
decName (TySynD n :: Name
n _ _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (ClassD _ n :: Name
n _ _ _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (SigD n :: Name
n _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (ForeignD fgn :: Foreign
fgn) = Name -> Maybe Name
forall a. a -> Maybe a
Just (Foreign -> Name
foreignName Foreign
fgn)
decName _ = Maybe Name
forall a. Maybe a
Nothing
foreignName :: Foreign -> Name
foreignName :: Foreign -> Name
foreignName (ImportF _ _ _ n :: Name
n _) = Name
n
foreignName (ExportF _ _ n :: Name
n _) = Name
n
unwindT :: Type -> [Type]
unwindT :: Type -> [Type]
unwindT = Type -> [Type]
go
where go :: Type -> [Type]
go :: Type -> [Type]
go (ForallT _ _ t :: Type
t) = Type -> [Type]
go Type
t
go (AppT (AppT ArrowT t :: Type
t) t' :: Type
t') = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
go Type
t'
go _ = []
unwindE :: Exp -> [Exp]
unwindE :: Exp -> [Exp]
unwindE = [Exp] -> Exp -> [Exp]
go []
where go :: [Exp] -> Exp -> [Exp]
go acc :: [Exp]
acc (e :: Exp
e `AppE` e' :: Exp
e') = [Exp] -> Exp -> [Exp]
go (Exp
e'Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
acc) Exp
e
go acc :: [Exp]
acc e :: Exp
e = Exp
eExp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
acc
arityT :: Type -> Int
arityT :: Type -> Int
arityT = Int -> Type -> Int
go 0
where go :: Int -> Type -> Int
go :: Int -> Type -> Int
go n :: Int
n (ForallT _ _ t :: Type
t) = Int -> Type -> Int
go Int
n Type
t
go n :: Int
n (AppT (AppT ArrowT _) t :: Type
t) =
let n' :: Int
n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1 in Int
n' Int -> Int -> Int
forall a b. a -> b -> b
`seq` Int -> Type -> Int
go Int
n' Type
t
go n :: Int
n _ = Int
n
typeToName :: Type -> Maybe Name
typeToName :: Type -> Maybe Name
typeToName t :: Type
t
| ConT n :: Name
n <- Type
t = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
| Type
ArrowT <- Type
t = Name -> Maybe Name
forall a. a -> Maybe a
Just ''(->)
| Type
ListT <- Type
t = Name -> Maybe Name
forall a. a -> Maybe a
Just ''[]
| TupleT n :: Int
n <- Type
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 _ _ t' :: Type
t' <- Type
t = Type -> Maybe Name
typeToName Type
t'
| Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf :: Name -> Maybe NameSpace
nameSpaceOf (Name _ (NameG ns :: NameSpace
ns _ _)) = NameSpace -> Maybe NameSpace
forall a. a -> Maybe a
Just NameSpace
ns
nameSpaceOf _ = Maybe NameSpace
forall a. Maybe a
Nothing
conName :: Con -> Name
conName :: Con -> Name
conName (RecC n :: Name
n _) = Name
n
conName (NormalC n :: Name
n _) = Name
n
conName (InfixC _ n :: Name
n _) = Name
n
conName (ForallC _ _ con :: Con
con) = Con -> Name
conName Con
con
conName c :: Con
c = String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "conName: TODO for" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
recCName :: Con -> Maybe Name
recCName :: Con -> Maybe Name
recCName (RecC n :: Name
n _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
recCName _ = Maybe Name
forall a. Maybe a
Nothing
dataDCons :: Dec -> [Con]
#if MIN_VERSION_template_haskell(2,11,0)
dataDCons :: Dec -> [Con]
dataDCons (DataD _ _ _ _ cons :: [Con]
cons _) = [Con]
cons
#else
dataDCons (DataD _ _ _ cons _) = cons
#endif
dataDCons _ = []
fromDataConI :: Info -> Q (Maybe Exp)
#if MIN_VERSION_template_haskell(2,11,0)
fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI (DataConI dConN :: Name
dConN ty :: Type
ty _tyConN :: Name
_tyConN) =
let n :: Int
n = Type -> Int
arityT Type
ty
in Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName "a")
Q [Name] -> ([Name] -> Q (Maybe Exp)) -> Q (Maybe Exp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ns :: [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
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)
(TupE $ fmap (Just . VarE) ns)
#else
([Exp] -> Exp
TupE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
ns)
#endif
))
#else
fromDataConI (DataConI dConN ty _tyConN _fxty) =
let n = arityT ty
in replicateM n (newName "a")
>>= \ns -> return (Just (LamE
[ConP dConN (fmap VarP ns)]
(TupE $ fmap VarE ns)))
#endif
fromDataConI _ = 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) = Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
dec
fromTyConI _ = Maybe Dec
forall a. Maybe a
Nothing
mkFunD :: Name -> [Pat] -> Exp -> Dec
mkFunD :: Name -> [Pat] -> Exp -> Dec
mkFunD f :: Name
f xs :: [Pat]
xs e :: 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 ps :: [PatQ]
ps e :: ExpQ
e = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
ps (ExpQ -> BodyQ
normalB ExpQ
e) []
toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ)
toExpQ :: (String -> Q a) -> String -> ExpQ
toExpQ parseQ :: 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 parseQ :: 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 toStr :: 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 ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
go)
where go :: Type -> Type
go :: Type -> Type
go (ConT n :: Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = Type
ListT
go (AppT (TupleT 1) t :: Type
t) = Type
t
go (ConT n :: Name
n)
| Just m :: 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 -> Type
TupleT (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
where
tupleNames :: [Name]
tupleNames = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
tupleTypeName [2 .. 64]
go t :: Type
t = Type
t