diff options
| -rw-r--r-- | src/HaddockHtml.hs | 68 | ||||
| -rw-r--r-- | src/Main.hs | 6 |
2 files changed, 49 insertions, 25 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 07d1dca8..fae29820 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -841,8 +841,7 @@ ppAsst n ts = ppDocName n <+> hsep (map ppType ts) -- Data & newtype declarations orig (L _ (NoLink name)) = name -orig _ = error "org" - +orig _ = error "orig" -- TODO: print contexts ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> @@ -856,14 +855,23 @@ ppShortDataDecl summary links loc mbDoc dataDecl | [] <- cons = ppDataHeader summary NewType name tyVars | otherwise = vanillaTable << ( - (if summary then declBox else topDeclBox links loc name) - (ppDataHeader summary newOrData name tyVars) </> - tda [theclass "body"] << vanillaTable << ( - aboves (zipWith doConstr ('=':repeat '|') cons) - ) + case resTy of + ResTyH98 -> dataHeader </> + tda [theclass "body"] << vanillaTable << ( + aboves (zipWith doConstr ('=':repeat '|') cons) + ) + ResTyGADT _ -> dataHeader </> + tda [theclass "body"] << vanillaTable << ( + aboves (zipWith doConstr (repeat "::") cons) + ) ) where + dataHeader = + (if summary then declBox else topDeclBox links loc name) + ((ppDataHeader summary newOrData name tyVars) <+> + case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) + doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con)) name = orig (tcdLName dataDecl) @@ -872,6 +880,7 @@ ppShortDataDecl summary links loc mbDoc dataDecl tyVars = tyvarNames (tcdTyVars dataDecl) mbKSig = tcdKindSig dataDecl cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons -- The rest of the cases: ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead2 DocName] -> key -> @@ -881,7 +890,7 @@ ppDataDecl summary links instances x loc mbDoc dataDecl | summary = declWithDoc summary links loc name mbDoc (ppShortDataDecl summary links loc mbDoc dataDecl) - | otherwise = dataheader </> + | otherwise = dataHeader </> tda [theclass "body"] << vanillaTable << ( datadoc </> constrBit </> @@ -895,9 +904,17 @@ ppDataDecl summary links instances x loc mbDoc dataDecl tyVars = tyvarNames (tcdTyVars dataDecl) mbKSig = tcdKindSig dataDecl cons = tcdCons dataDecl - - dataheader = topDeclBox links loc name - (ppDataHeader False newOrData name tyVars) + resTy = (con_res . unLoc . head) cons + + dataHeader = + (if summary then declBox else topDeclBox links loc name) + ((ppDataHeader summary newOrData name tyVars) <+> whereBit) + + whereBit + | null cons = empty + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> empty constrTable | any isRecCon cons = spacedTable5 @@ -939,14 +956,19 @@ ppShortConstr summary con = case con_res con of RecCon fields -> header +++ ppBinder summary name <+> braces (vanillaTable << aboves (map (ppShortField summary) fields)) - ResTyGADT ltype -> error "GADTs not supported yet" - + ResTyGADT resTy -> case con_details con of + PrefixCon args -> ppName name <+> dcolon <+> hsep [ + ppForAll forall ltvs lcontext, + ppLType (foldr mkFunTy resTy args) ] where - header = ppConstrHdr forall tyVars context - name = orig (con_name con) - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall = con_explicit con + header = ppConstrHdr forall tyVars context + name = orig (con_name con) + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html ppConstrHdr forall tvs ctxt @@ -970,7 +992,7 @@ ppSideBySideConstr (L _ con) = case con_res con of (tda [theclass "body"] << spacedTable1 << aboves (map ppSideBySideField fields)) - ResTyGADT ltype -> error "GADTs not supported yet" + ResTyGADT ltype -> emptyTable --error "GADTs not supported yet" where header = ppConstrHdr forall tyVars context @@ -1054,13 +1076,15 @@ ppCtxtPart (L _ ctxt) | null ctxt = empty | otherwise = hsep [ppContext ctxt, darrow] -ppForAll (HsForAllTy Implicit _ lctxt _) = ppCtxtPart lctxt -ppForAll (HsForAllTy Explicit ltvs lctxt _) = +ppForAllTy (HsForAllTy expl ltvs lctxt _) = ppForAll expl ltvs lctxt + +ppForAll Implicit _ lctxt = ppCtxtPart lctxt +ppForAll Explicit ltvs lctxt = hsep (keyword "forall" : ppTyVars ltvs ++ [toHtml "."]) <+> ppCtxtPart lctxt ppType :: HsType DocName -> Html ppType t = case t of - t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAll t <+> ppLType ltype + t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype HsTyVar n -> ppDocName n HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt diff --git a/src/Main.hs b/src/Main.hs index 2e06fc8d..de0f99d9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -191,20 +191,20 @@ sortAndCheckModules session flags files = defaultErrorHandler flags $ do mbModGraph <- depanal session [] True moduleGraph <- case mbModGraph of Just mg -> return mg - Nothing -> die "Failed to load all modules\n" + Nothing -> die "Failed to load all modules\n" let modSumFile = fromJust . ml_hs_file . ms_location sortedGraph = topSortModuleGraph False moduleGraph Nothing sortedModules = concatMap Digraph.flattenSCC sortedGraph modsAndFiles = [ (ms_mod modsum, modSumFile modsum) | modsum <- sortedModules, - modSumFile modsum `elem` files ] + modSumFile modsum `elem` files ] checkedMods <- mapM (\(mod, file) -> do mbMod <- checkModule session (moduleName mod) checkedMod <- case mbMod of Just m -> return m Nothing -> die ("Failed to load module: " ++ moduleString mod) - return (mod, checkedMod, file)) modsAndFiles + return (mod, checkedMod, file)) modsAndFiles ensureFullyChecked checkedMods where ensureFullyChecked modules |