aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-09-03 16:06:59 +0000
committerdavve <davve@dtek.chalmers.se>2006-09-03 16:06:59 +0000
commit3cc9be3b11007fe0eb3e55a6a09b22f6b73243f4 (patch)
tree631c4b8e848286de5a5d5ef03ac00c45d03bd5b6 /src
parentda3a10238905c825bfc916117f4c4895bb5c6284 (diff)
Starting work on GADT rendering
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHtml.hs68
-rw-r--r--src/Main.hs6
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