module Language.Haskell.TH.Desugar.Util where
import Prelude hiding (mapM)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Quasi(..), mkNameG_tc, mkNameG_d )
import qualified Data.Set as S
import Data.Foldable
import Data.Generics
import Data.Traversable
import Data.Monoid
reifyWithWarning :: Quasi q => Name -> q Info
reifyWithWarning name = qRecover
(fail $ "Looking up " ++ (show name) ++ " in the list of available " ++
"declarations failed.\nThis lookup fails if the declaration " ++
"referenced was made in the same Template\nHaskell splice as the use " ++
"of the declaration. If this is the case, put\nthe reference to " ++
"the declaration in a new splice.")
(qReify name)
newUniqueName :: Quasi q => String -> q Name
newUniqueName str = do
n <- qNewName str
qNewName $ show n
impossible :: Quasi q => String -> q a
impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email eir@cis.upenn.edu with your code if you see this.")
getDataD :: Quasi q
=> String
-> Name
-> q ([TyVarBndr], [Con])
getDataD err name = do
info <- reifyWithWarning name
dec <- case info of
TyConI dec -> return dec
_ -> badDeclaration
case dec of
DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)
NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])
_ -> badDeclaration
where badDeclaration =
fail $ "The name (" ++ (show name) ++ ") refers to something " ++
"other than a datatype. " ++ err
dataConNameToDataName :: Quasi q => Name -> q Name
dataConNameToDataName con_name = do
info <- reifyWithWarning con_name
case info of
DataConI _name _type parent_name _fixity -> return parent_name
_ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++
"a data constructor."
dataConNameToCon :: Quasi q => Name -> q Con
dataConNameToCon con_name = do
type_name <- dataConNameToDataName con_name
(_, cons) <- getDataD "This seems to be an error in GHC." type_name
let m_con = find ((con_name ==) . get_con_name) cons
case m_con of
Just con -> return con
Nothing -> impossible "Datatype does not contain one of its own constructors."
where
get_con_name (NormalC name _) = name
get_con_name (RecC name _) = name
get_con_name (InfixC _ name _) = name
get_con_name (ForallC _ _ con) = get_con_name con
nameOccursIn :: Data a => Name -> a -> Bool
nameOccursIn n = everything (||) $ mkQ False (== n)
allNamesIn :: Data a => a -> [Name]
allNamesIn = everything (++) $ mkQ [] (:[])
mkTypeName :: Quasi q => String -> q Name
mkTypeName str = do
m_name <- qLookupName True str
case m_name of
Just name -> return name
Nothing -> do
Loc { loc_package = pkg, loc_module = modu } <- qLocation
return $ mkNameG_tc pkg modu str
mkDataName :: Quasi q => String -> q Name
mkDataName str = do
m_name <- qLookupName False str
case m_name of
Just name -> return name
Nothing -> do
Loc { loc_package = pkg, loc_module = modu } <- qLocation
return $ mkNameG_d pkg modu str
stripVarP_maybe :: Pat -> Maybe Name
stripVarP_maybe (VarP name) = Just name
stripVarP_maybe _ = Nothing
stripPlainTV_maybe :: TyVarBndr -> Maybe Name
stripPlainTV_maybe (PlainTV n) = Just n
stripPlainTV_maybe _ = Nothing
extractBoundNamesStmt :: Stmt -> S.Set Name
extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat
extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs
extractBoundNamesStmt (NoBindS _) = S.empty
extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss
extractBoundNamesDec :: Dec -> S.Set Name
extractBoundNamesDec (FunD name _) = S.singleton name
extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat
extractBoundNamesDec _ = S.empty
extractBoundNamesPat :: Pat -> S.Set Name
extractBoundNamesPat (LitP _) = S.empty
extractBoundNamesPat (VarP name) = S.singleton name
extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats
extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats
extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats
extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `S.union`
extractBoundNamesPat p2
extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `S.union`
extractBoundNamesPat p2
extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat
extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat
extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat
extractBoundNamesPat (AsP name pat) = S.singleton name `S.union` extractBoundNamesPat pat
extractBoundNamesPat WildP = S.empty
extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in
foldMap extractBoundNamesPat pats
extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats
extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat
extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat
splitAtList :: [a] -> [b] -> ([b], [b])
splitAtList [] x = ([], x)
splitAtList (_ : t) (x : xs) =
let (as, bs) = splitAtList t xs in
(x : as, bs)
splitAtList (_ : _) [] = ([], [])
splitTuple_maybe :: Type -> Maybe [Type]
splitTuple_maybe = go []
where
go acc (AppT left right) = go (right:acc) left
go acc (SigT ty _) = go acc ty
go acc (TupleT n)
| n == length acc = Just acc
go acc (ConT name)
| Just n <- tupleNameDegree_maybe name
, n == length acc = Just acc
go _ _ = Nothing
tupleDegree_maybe :: String -> Maybe Int
tupleDegree_maybe s = do
'(' : s1 <- return s
(commas, ")") <- return $ span (== ',') s1
let degree
| "" <- commas = 0
| otherwise = length commas + 1
return degree
tupleNameDegree_maybe :: Name -> Maybe Int
tupleNameDegree_maybe = tupleDegree_maybe . nameBase
liftSnd :: (a -> b) -> (c, a) -> (c, b)
liftSnd f (c, a) = (c, f a)
liftSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b)
liftSndM f (c, a) = f a >>= return . (c, )
liftThdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)
liftThdOf3 f (c, d, a) = (c, d, f a)
liftThdOf3M :: Monad m => (a -> m b) -> (c, d, a) -> m (c, d, b)
liftThdOf3M f (c, d, a) = f a >>= return . (c, d, )
concatMapM :: (Monad monad, Monoid monoid, Traversable t)
=> (a -> monad monoid) -> t a -> monad monoid
concatMapM fn list = do
bss <- mapM fn list
return $ fold bss