module Language.Haskell.TH.Context
( InstMap
, DecStatus(Declared, Undeclared, instanceDec)
, reifyInstancesWithContext
, tellInstance
, tellUndeclared
) where
import Data.Maybe (isJust)
import Control.Monad (filterM)
import Control.Monad.States (MonadStates, get, modify)
import Control.Monad.Writer (MonadWriter, tell)
import Data.Generics (everywhere, mkT)
import Data.List (intercalate)
import Data.Map as Map (elems, insert, lookup, Map)
import Data.Maybe (mapMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Desugar as DS (DsMonad)
import Language.Haskell.TH.PprLib (cat, ptext)
import Language.Haskell.TH.Syntax hiding (lift)
import Language.Haskell.TH.TypeGraph.Expand (ExpandMap, expandType, E(unE))
import Language.Haskell.TH.Instances ()
type InstMap = Map (E Pred) [DecStatus InstanceDec]
data DecStatus a
= Declared {instanceDec :: a}
| Undeclared {instanceDec :: a}
deriving Show
instance Ppr a => Ppr (DecStatus a) where
ppr (Undeclared x) = cat [ptext "Undeclared (", ppr x, ptext ")"]
ppr (Declared x) = cat [ptext "Declared (", ppr x, ptext ")"]
reifyInstancesWithContext :: forall m. (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) =>
Name -> [Type] -> m [InstanceDec]
reifyInstancesWithContext className typeParameters = do
p <- expandType $ foldInstance className typeParameters
mp <- get :: m InstMap
case Map.lookup p mp of
Just x -> return $ map instanceDec x
Nothing -> do
modify (Map.insert p [] :: InstMap -> InstMap)
insts <- qReifyInstances className typeParameters
r <- filterM (testInstance className typeParameters) insts
modify (Map.insert p (map Declared r))
return r
testInstance :: (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => Name -> [Type] -> InstanceDec -> m Bool
testInstance className typeParameters (InstanceD instanceContext instanceType _) = do
mapM expandType (instancePredicates (reverse typeParameters) instanceType ++ instanceContext) >>= testContext . map unE
where
instancePredicates :: [Type] -> Type -> [Pred]
instancePredicates (x : xs) (AppT l r) = AppT (AppT EqualityT x) r : instancePredicates xs l
instancePredicates [] (ConT className') | className == className' = []
instancePredicates _ _ =
error $ (unlines ["testInstance: Failure unifying instance with arguments. This should never",
"happen because qReifyInstance returned this instance for these exact arguments:",
" typeParameters=[" ++ intercalate ", " (map show typeParameters) ++ "]",
" instanceType=" ++ show instanceType])
testInstance _ _ x = error $ "qReifyInstances returned something that doesn't appear to be an instance declaration: " ++ show x
testContext :: (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => [Pred] -> m Bool
testContext context =
and <$> (simplifyContext context >>= mapM consistent)
simplifyContext :: (DsMonad m, MonadStates InstMap m) => [Pred] -> m [Pred]
simplifyContext context =
do let context' = concat $ map unify context
let context'' = foldl simplifyPredicate context' context'
if (context'' == context) then return context'' else simplifyContext context''
simplifyPredicate :: [Pred] -> Pred -> [Pred]
simplifyPredicate context (AppT (AppT EqualityT v@(VarT _)) b) = everywhere (mkT (\ x -> if x == v then b else x)) context
simplifyPredicate context (AppT (AppT EqualityT a) v@(VarT _)) = everywhere (mkT (\ x -> if x == v then a else x)) context
simplifyPredicate context p@(AppT (AppT EqualityT a) b) | a == b = filter (/= p) context
simplifyPredicate context _ = context
unify :: Pred -> [Pred]
unify (AppT (AppT EqualityT (AppT a b)) (AppT c d)) = unify (AppT (AppT EqualityT a) c) ++ unify (AppT (AppT EqualityT b) d)
unify (AppT (AppT EqualityT (ConT a)) (ConT b)) | a == b = []
unify (AppT (AppT EqualityT a@(VarT _)) b) = [AppT (AppT EqualityT a) b]
unify (AppT (AppT EqualityT a) b@(VarT _)) = [AppT (AppT EqualityT a) b]
unify x = [x]
consistent :: (DsMonad m, MonadStates InstMap m, MonadStates ExpandMap m) => Pred -> m Bool
consistent typ
| isJust (unfoldInstance typ) =
let Just (className, typeParameters) = unfoldInstance typ in
(not . null) <$> reifyInstancesWithContext className typeParameters
consistent (AppT (AppT EqualityT (AppT a b)) (AppT c d)) =
(&&) <$> consistent (AppT (AppT EqualityT a) c) <*> consistent (AppT (AppT EqualityT b) d)
consistent (AppT (AppT EqualityT (VarT _)) _) = return True
consistent (AppT (AppT EqualityT _) (VarT _)) = return True
consistent (AppT (AppT EqualityT a) b) | a == b = return True
consistent (AppT (AppT EqualityT _) _) = return False
consistent typ = error $ "Unexpected Pred: " ++ pprint typ
tellInstance :: (DsMonad m, MonadStates InstMap m, Quasi m, MonadStates ExpandMap m) => Dec -> m ()
tellInstance inst@(InstanceD _ instanceType _) =
do let Just (className, typeParameters) = unfoldInstance instanceType
p <- expandType $ foldInstance className typeParameters
(mp :: InstMap) <- get
case Map.lookup p mp of
Just (_ : _) -> return ()
_ -> modify (Map.insert p [Undeclared inst])
tellInstance inst = error $ "tellInstance - Not an instance: " ++ pprint inst
tellUndeclared :: (MonadWriter [Dec] m, MonadStates InstMap m) => m ()
tellUndeclared =
get >>= \(mp :: InstMap) -> tell . mapMaybe undeclared . concat . Map.elems $ mp
where
undeclared :: DecStatus Dec -> Maybe Dec
undeclared (Undeclared dec) = Just dec
undeclared (Declared _) = Nothing
foldInstance :: Name -> [Type] -> Pred
foldInstance className typeParameters = foldl AppT (ConT className) typeParameters
unfoldInstance :: Pred -> Maybe (Name, [Type])
unfoldInstance (ConT name) = Just (name, [])
unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1)
unfoldInstance _ = Nothing