{-# 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 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 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 = 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 = 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 :: Type -> Type
unForall (ForallT [TyVarBndr]
_ Cxt
_ Type
t) = Type
t
unForall 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


-- | 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] -> Type -> (Type, [(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] -> 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
_ = String -> (Type, [(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 -> 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 [(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]
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 [] ((TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
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) -> Cxt -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> 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
        (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] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
ns'' Cxt
cxt' Type
t', [(Name, Name)]
env4, [Name]
new4)
  where
    unVarT :: Type -> TyVarBndr
unVarT (VarT Name
n) = Name -> TyVarBndr
PlainTV Name
n
    unVarT Type
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]
++ Type -> String
forall a. Show a => a -> String
show Type
ty
    renamePreds :: [(Name, Name)]
-> [Name] -> Cxt -> Cxt -> (Cxt, [(Name, Name)], [Name])
renamePreds = ([(Name, Name)]
 -> [Name] -> Type -> (Type, [(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] -> 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 = 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
$ String
"renameT: TODO for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
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 :: Type -> Type -> Type
applyT (ForallT [] Cxt
_ Type
t) Type
t' = Type
t Type -> Type -> Type
`AppT` Type
t'
applyT (ForallT (TyVarBndr
n:[TyVarBndr]
ns) Cxt
cxt Type
t) Type
t' = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
ns Cxt
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 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]
ns Cxt
_ 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 [(Name, Type)]
env [Name]
bnd t :: Type
t@(VarT 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 [(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) = (StrictType -> Type) -> [StrictType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Type
strictTypeTy [StrictType]
sts
conTypes (RecC    Name
_ [VarStrictType]
vts) = (VarStrictType -> Type) -> [VarStrictType] -> Cxt
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') = (StrictType -> Type) -> [StrictType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictType -> Type
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 :: Type -> Con -> Type
conToConType Type
ofType Con
con = (Type -> Type -> Type) -> Type -> Cxt -> Type
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)



decCons :: Dec -> [Con]
#if MIN_VERSION_template_haskell(2,11,0)
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]
#else
decCons (DataD _ _ _ cons _)     = cons
decCons (NewtypeD _ _ _ con _)   = [con]
#endif
decCons Dec
_                        = []


decTyVars :: Dec -> [TyVarBndr]
#if MIN_VERSION_template_haskell(2,11,0)
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
#else
decTyVars (DataD _ _ ns _ _)      = ns
decTyVars (NewtypeD _ _ ns _ _)   = ns
#endif
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]
_)             = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
#if MIN_VERSION_template_haskell(2,11,0)
decName (DataD Cxt
_ Name
n [TyVarBndr]
_ Maybe Type
_ [Con]
_ [DerivClause]
_)    = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
decName (NewtypeD Cxt
_ Name
n [TyVarBndr]
_ Maybe Type
_ Con
_ [DerivClause]
_) = 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 Name
n [TyVarBndr]
_ Type
_)         = 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 Type
_)             = 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 Type
_) = Name
n
foreignName (ExportF Callconv
_ String
_ Name
n Type
_)   = Name
n


unwindT :: Type -> [Type]
unwindT :: Type -> Cxt
unwindT = Type -> Cxt
go
  where go :: Type -> [Type]
        go :: Type -> Cxt
go (ForallT [TyVarBndr]
_ Cxt
_ Type
t)           = Type -> Cxt
go Type
t
        go (AppT (AppT Type
ArrowT Type
t) Type
t') = Type
t Type -> Cxt -> Cxt
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'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 :: Type -> Int
arityT = Int -> Type -> Int
go Int
0
  where go :: Int -> Type -> Int
        go :: Int -> Type -> Int
go Int
n (ForallT [TyVarBndr]
_ 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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in Int
n' Int -> Int -> Int
`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 = 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 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 [TyVarBndr]
_ Cxt
_ Type
t' <- Type
t = Type -> Maybe Name
typeToName Type
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

dataDCons :: Dec -> [Con]
#if MIN_VERSION_template_haskell(2,11,0)
dataDCons :: Dec -> [Con]
dataDCons (DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) = [Con]
cons
#else
dataDCons (DataD _ _ _ cons _)   = cons
#endif
dataDCons Dec
_                      = []

fromDataConI :: Info -> Q (Maybe Exp)
#if MIN_VERSION_template_haskell(2,11,0)
fromDataConI :: Info -> Q (Maybe Exp)
fromDataConI (DataConI Name
dConN Type
ty 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 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
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
                    ))
#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 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 ((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 Name
n) | Name
n Name -> Name -> Bool
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 <- (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
+ 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 Type
t = Type
t



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