module Unsafe.TrueName (summon, truename) where
import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Data.List (nub)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
conNames :: Con -> [Name]
conNames con = case con of
NormalC name _ -> [name]
RecC name fields -> name : [ fname | (fname, _, _) <- fields ]
InfixC _ name _ -> [name]
ForallC _ _ con' -> conNames con'
decNames :: Dec -> [Name]
decNames dec = case dec of
FunD _ _ -> []
ValD _ _ _ -> []
DataD _ _ _ cons _ -> conNames =<< cons
NewtypeD _ _ _ con _ -> conNames con
TySynD _ _ typ -> typNames typ
ClassD _ _ _ _ decs -> decNames =<< decs
InstanceD cxt typ decs -> (predNames =<< cxt)
++ typNames typ ++ (decNames =<< decs)
SigD name typ -> name : typNames typ
ForeignD frgn -> case frgn of
ImportF _ _ _ name t -> name : typNames t
ExportF _ _ name t -> name : typNames t
#if MIN_VERSION_template_haskell(2,8,0)
InfixD _ _ -> []
#endif
PragmaD _ -> []
FamilyD _ _ _ _ -> []
DataInstD cxt _ _ cons names -> (conNames =<< cons)
++ names ++ (predNames =<< cxt)
NewtypeInstD cxt _ _ con names -> conNames con
++ names ++ (predNames =<< cxt)
#if !MIN_VERSION_template_haskell(2,9,0)
TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t
#else
TySynInstD _ tse -> tseNames tse
ClosedTypeFamilyD _ _ _ tses -> tseNames =<< tses
RoleAnnotD _ _ -> []
#endif
#if MIN_VERSION_template_haskell(2,10,0)
StandaloneDerivD cxt typ -> (predNames =<< cxt) ++ typNames typ
DefaultSigD _ _ -> []
#endif
#if MIN_VERSION_template_haskell(2,9,0)
tseNames :: TySynEqn -> [Name]
tseNames (TySynEqn ts t) = (typNames =<< ts) ++ typNames t
#endif
predNames :: Pred -> [Name]
#if !MIN_VERSION_template_haskell(2,10,0)
predNames p = case p of
ClassP n ts -> n : (typNames =<< ts)
EqualP s t -> typNames s ++ typNames t
#else
predNames = typNames
#endif
typNames :: Type -> [Name]
typNames typ = case typ of
ForallT _ c t -> (predNames =<< c) ++ typNames t
AppT s t -> typNames s ++ typNames t
SigT t _ -> typNames t
VarT _ -> []
ConT name -> [name]
TupleT _ -> []
UnboxedTupleT _ -> []
ArrowT -> []
ListT -> []
#if MIN_VERSION_template_haskell(2,8,0)
PromotedT _ -> []
PromotedTupleT _ -> []
PromotedNilT -> []
PromotedConsT -> []
StarT -> []
ConstraintT -> []
LitT _ -> []
#endif
#if MIN_VERSION_template_haskell(2,10,0)
EqualityT -> []
#endif
infoNames :: Info -> [Name]
infoNames info = case info of
ClassI dec _ -> decNames dec
ClassOpI _ typ _ _ -> typNames typ
TyConI dec -> decNames dec
FamilyI _ decs -> decNames =<< decs
DataConI _ typ parent _ -> parent : typNames typ
VarI _ typ _ _ -> typNames typ
PrimTyConI _ _ _ -> []
TyVarI _ typ -> typNames typ
summon :: String -> Name -> Q Name
summon name thing = do
info <- reify thing
let ns = nub (infoNames info)
case filter (\ n -> name == nameBase n || name == show n) ns of
[n] -> return n
_ -> fail $ "summon: you wanted " ++ show name ++ ", but I have:\n"
++ unlines ((++) " " . namespace <$> ns)
++ " reify " ++ show thing ++ " returned:\n"
++ show (nest 8 $ ppr info)
where
namespace n@(Name _ flavour) = show n ++ case flavour of
NameG VarName _ _ -> " (var)"
NameG DataName _ _ -> " (cons)"
NameG TcClsName _ _ -> " (type)"
_ -> " (?)"
truename :: QuasiQuoter
truename = QuasiQuoter
{ quoteExp = makeE <=< nameVars
, quotePat = makeP <=< nameVars
, quoteType = makeT <=< nameVars
, quoteDec = \ _ -> err "I'm not sure how this would work"
} where
err = fail . (++) "truename: "
noPat = err . (++) "unexpected pattern variables: " . unwords
makeT (name, vars) = ConT name <$ unless (null vars) (noPat vars)
makeE (name@(Name occ flavour), vars) = case flavour of
NameG VarName _ _ -> VarE name <$ unless (null vars) (noPat vars)
NameG DataName _ _ -> case vars of
[] -> return (ConE name)
[".."] -> RecConE name . capture VarE <$> recFields name
_ -> noPat vars
_ -> err $ occString occ ++ " has a strange flavour"
makeP (name, vars) = if vars == [".."]
then RecP name . capture VarP <$> recFields name
else return $ ConP name (map pat vars) where
pat n = case n of
"_" -> WildP
'!' : ns -> BangP (pat ns)
'~' : ns -> TildeP (pat ns)
_ -> VarP (mkName n)
capture v = map $ \ f -> (f, v (mkName $ nameBase f))
recFields :: Name -> Q [Name]
recFields name = do
parent <- reify name >>= \ info -> case info of
DataConI _ _ p _ -> return p
_ -> err $ show name ++ " is not a data constructor"
dec <- reify parent >>= \ info -> case info of
TyConI d -> return d
_ -> err $ "parent " ++ show parent ++ " is not a plain type"
case dec of
DataD _ _ _ cs _ -> return $ concatMap fields cs
NewtypeD _ _ _ c _ -> return $ fields c
_ -> err $ "parent " ++ show parent ++ " neither data nor newtype"
where
fields :: Con -> [Name]
fields con = case con of
NormalC _ _ -> []
RecC n vsts -> if n /= name then [] else [ v | (v, _, _) <- vsts ]
InfixC _ _ _ -> []
ForallC _ _ c -> fields c
lookupThing :: String -> Q Name
lookupThing s0 = case s0 of
'\'' : s1 -> case s1 of
'\'' : s2 -> hmm s2 "lookupTypeName" =<< lookupTypeName s2
_ -> hmm s1 "lookupValueName" =<< lookupValueName s1
_ -> err $ "please specify either '" ++ s0 ++ " or ''" ++ s0
where
hmm s l = maybe (err $ unwords [l, show s, "failed"]) return
nameVars :: String -> Q (Name, [String])
nameVars spec = case words spec of
[] -> err "expecting at least one token"
start : rest -> do
thing <- lookupThing start
let (names, vars) = break ("|" ==) rest
name <- foldM (flip summon) thing names
return (name, dropWhile ("|" ==) vars)