module Language.Haskell.TH.TypeGraph.Info
( TypeGraphInfo
, emptyTypeGraphInfo
, typeGraphInfo
, fields, hints, infoMap, synonyms, typeSet
) where
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid (mempty)
#endif
import Control.Lens
import Control.Monad.State (execStateT, StateT)
import Data.List as List (intercalate, map)
import Data.Map as Map (insert, insertWith, Map, toList)
import Data.Set as Set (insert, member, Set, singleton, toList, union)
import Language.Haskell.Exts.Syntax ()
import Language.Haskell.TH
import Language.Haskell.TH.TypeGraph.Core (Field, pprint')
import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)
import Language.Haskell.TH.TypeGraph.Hints (HasVertexHints(hasVertexHints), vertexHintTypes)
import Language.Haskell.TH.Desugar as DS (DsMonad)
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.PprLib (ptext)
import Language.Haskell.TH.Syntax (Lift(lift), Quasi(..))
data TypeGraphInfo hint
= TypeGraphInfo
{ _typeSet :: Set Type
, _infoMap :: Map Name Info
, _expanded :: Map Type (E Type)
, _synonyms :: Map (E Type) (Set Name)
, _fields :: Map (E Type) (Set (Name, Name, Either Int Name))
, _hints :: [(Maybe Field, Name, hint)]
} deriving (Show, Eq, Ord)
instance Ppr hint => Ppr (TypeGraphInfo hint) where
ppr (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = hs}) =
ptext $ intercalate "\n " ["TypeGraphInfo:", ppt, ppi, ppe, pps, ppf, pph] ++ "\n"
where
ppt = intercalate "\n " ("typeSet:" : concatMap (lines . pprint) (Set.toList t))
ppi = intercalate "\n " ("infoMap:" : concatMap (lines . (\ (name, info) -> show name ++ " -> " ++ pprint info)) (Map.toList i))
ppe = intercalate "\n " ("expanded:" : concatMap (lines . (\ (typ, (E etyp)) -> pprint typ ++ " -> " ++ pprint etyp)) (Map.toList e))
pps = intercalate "\n " ("synonyms:" : concatMap (lines . (\ (typ, ns) -> pprint typ ++ " -> " ++ show ns)) (Map.toList s))
ppf = intercalate "\n " ("fields:" : concatMap (lines . (\ (typ, fs) -> pprint typ ++ " -> " ++ show fs)) (Map.toList f))
pph = intercalate "\n " ("hints:" : concatMap (lines . (\ (fld, tname, h) -> pprint (fld, (ConT tname)) ++ " -> " ++ pprint h)) hs)
$(makeLenses ''TypeGraphInfo)
instance Lift hint => Lift (TypeGraphInfo hint) where
lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = h}) =
[| TypeGraphInfo { _typeSet = $(lift t)
, _infoMap = $(lift i)
, _expanded = $(lift e)
, _synonyms = $(lift s)
, _fields = $(lift f)
, _hints = $(lift h)
} |]
emptyTypeGraphInfo :: TypeGraphInfo hint
emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty, _hints = mempty}
collectTypeInfo :: forall m hint. (DsMonad m, HasVertexHints hint) => Type -> StateT (TypeGraphInfo hint) m ()
collectTypeInfo typ0 = do
doType typ0
where
doType :: Type -> StateT (TypeGraphInfo hint) m ()
doType typ = do
(s :: Set Type) <- use typeSet
case Set.member typ s of
True -> return ()
False -> do typeSet %= Set.insert typ
etyp <- expandType typ
expanded %= Map.insert typ etyp
doType' typ
doType' :: Type -> StateT (TypeGraphInfo hint) m ()
doType' (ConT name) = do
info <- qReify name
infoMap %= Map.insert name info
doInfo name info
doType' (AppT typ1 typ2) = doType typ1 >> doType typ2
doType' ListT = return ()
doType' (VarT _) = return ()
doType' (TupleT _) = return ()
doType' typ = error $ "typeGraphInfo: " ++ pprint' typ
doInfo :: Name -> Info -> StateT (TypeGraphInfo hint) m ()
doInfo _tname (TyConI dec) = doDec dec
doInfo _tname (PrimTyConI _ _ _) = return ()
doInfo _tname (FamilyI _ _) = return ()
doInfo _ info = error $ "typeGraphInfo: " ++ show info
doDec :: Dec -> StateT (TypeGraphInfo hint) m ()
doDec (TySynD tname _ typ) = do
etyp <- expandType (ConT tname)
synonyms %= Map.insertWith union etyp (singleton tname)
doType typ
doDec (NewtypeD _ tname _ constr _) = doCon tname constr
doDec (DataD _ tname _ constrs _) = mapM_ (doCon tname) constrs
doDec dec = error $ "typeGraphInfo: " ++ pprint' dec
doCon :: Name -> Con -> StateT (TypeGraphInfo hint) m ()
doCon tname (ForallC _ _ con) = doCon tname con
doCon tname (NormalC cname flds) = mapM_ doField (zip (List.map (\n -> (tname, cname, Left n)) ([1..] :: [Int])) (List.map snd flds))
doCon tname (RecC cname flds) = mapM_ doField (List.map (\ (fname, _, ftype) -> ((tname, cname, Right fname), ftype)) flds)
doCon tname (InfixC (_, lhs) cname (_, rhs)) = mapM_ doField [((tname, cname, Left 1), lhs), ((tname, cname, Left 2), rhs)]
doField :: ((Name, Name, Either Int Name), Type) -> StateT (TypeGraphInfo hint) m ()
doField (fld, ftyp) = do
etyp <- expandType ftyp
fields %= Map.insertWith union etyp (singleton fld)
doType ftyp
collectHintInfo :: (DsMonad m, HasVertexHints hint) => (Maybe Field, Name, hint) -> StateT (TypeGraphInfo hint) m ()
collectHintInfo (fld, tname, h) = hints %= (++ [(fld, tname, h)])
typeGraphInfo :: forall m hint. (DsMonad m, HasVertexHints hint) => [(Maybe Field, Name, hint)] -> [Type] -> m (TypeGraphInfo hint)
typeGraphInfo hintList types = flip execStateT emptyTypeGraphInfo $ do
mapM hasVertexHints (List.map (view _3) hintList) >>= mapM_ collectTypeInfo . (types ++) . concatMap vertexHintTypes . concat
mapM_ collectHintInfo hintList