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


decCons :: Dec -> [Con]
decCons :: Dec -> [Con]
decCons (DataD _ _ _ _ cons :: [Con]
cons _)   = [Con]
cons
decCons (NewtypeD _ _ _ _ con :: Con
con _) = [Con
con]
decCons _                        = []


decTyVars :: Dec -> [TyVarBndr_ ()]
decTyVars :: Dec -> [TyVarBndr_ ()]
decTyVars (DataD _ _ ns :: [TyVarBndr_ ()]
ns _ _ _)    = [TyVarBndr_ ()]
ns
decTyVars (NewtypeD _ _ ns :: [TyVarBndr_ ()]
ns _ _ _) = [TyVarBndr_ ()]
ns
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
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
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


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


-- | 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
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 = 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 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


-- | 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]
:[]) ['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)

-- | 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 _ 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

-- | renameT applied to a list of types
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

-- | 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 _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_ ()
Compat.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

-- | 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 [] _ 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
-- TODO
            -- (GadtC _ _ _)
            -- (RecGadtC _ _ _)


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)




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


-- | The arity of a Type.
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

-- | Randomly useful.
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
-- TODO
            -- (GadtC _ _ _)
            -- (RecGadtC _ _ _)

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

fromDataConI :: Info -> Q (Maybe Exp)
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
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)
                    (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
                    ))
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) []

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

-- | 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 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



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