module HDocDefs where import Char import List import Maybe import Scanner (Tag(..), TagAttr(..)) import Unicode import HsSyn data Package = NoPackage | UnknownPackage | PackageName String deriving Eq data HsMod = HsMod { hsmHsModule :: HsModule, hsmPackage :: Package } data HDocSettings = HDS { hdsExportsOnly :: Bool, hdsLineNumbers :: Bool, hdsDocumentTitle :: String, hdsDestinationDir :: FilePath, hdsDirSeparator :: String, hdsStyleSheetFile :: Maybe FilePath } data HDocInput = HDI { allModules :: [ModuleDoc], visibleModules :: [ModuleDoc], hiddenModules :: [ModuleDoc] } deriving (Show) type HDocText = [HDocElement] data HDocElement = HdeText String | HdeWhiteSpace | HdeTag1 STag | HdeTag2 Tag [TagAttr] HDocText | HdeUnicode Unicode | HdeHDocRef HDR deriving Show data STag = BrTag deriving Show data HDR = FunctionRef FunctionDoc | DataRef DataDoc | TypeRef TypeDoc | ClassRef ClassDoc -- | ModuleRef ModuleDoc deriving Show instance CanAppear HDR where appearsInOutput (FunctionRef f) = appearsInOutput f appearsInOutput (DataRef d) = appearsInOutput d appearsInOutput (TypeRef t) = appearsInOutput t appearsInOutput (ClassRef c) = appearsInOutput c setAppearance _ = error "setAppearance should never be called on HDR. \n\ \ This is a bug in HDoc, please report it." instance HasHDocName HDR where hdocName (FunctionRef f) = hdocName f hdocName (DataRef d) = hdocName d hdocName (TypeRef t) = hdocName t hdocName (ClassRef c) = hdocName c -- return the HDR object referencing the object named by `name'. findHdr :: ModuleDoc -> String -> Maybe HDR findHdr md name = case lookupExport md (hsQNameFromString name) of Just (ExportFunction f) -> Just $ FunctionRef f Just (ExportData d _) -> Just $ DataRef d Just (ExportType t _) -> Just $ TypeRef t Just (ExportClass c _) -> Just $ ClassRef c _ -> Nothing class HasDescription a where description :: a -> HDocText class HasHDocName a where hdocName :: a -> HDocName class HasTypedef a where typedef :: a -> Type class CanAppear a where appearsInOutput :: a -> Bool setAppearance :: a -> Bool -> a class Reexportable a where reexport :: a -> ModuleDoc -> a class HasSeeTags a where seeTags :: a -> [HDR] -- use "x = f a" or "x <- f a" in the usage example in the output data RetType = Functional | Monadic deriving (Eq, Show) -- where a function belongs to data FunClass = NoClass | Class ClassDoc | Instance InstanceDoc deriving (Eq) instance Reexportable FunClass where reexport NoClass _ = NoClass reexport (Class c) md = Class (reexport c md) reexport (Instance i) md = Instance (reexport i md) instance Show FunClass where show NoClass = "NoClass" show (Class c) = "Class \"" ++ fullname c ++ "\"" show (Instance i) = "Instance \"" ++ fullname i ++ "\"" -- the name and containing module of a HDoc object data HDocName = HN { objectModule :: ModuleDoc, objectName :: String, srcModule :: ModuleDoc, srcLocation :: SrcLoc } instance Eq HDocName where a == b = objectName a == objectName b && srcModule a == srcModule b && srcLocation a == srcLocation b instance Show HDocName where show hn = "HN:" ++ moduleName (objectModule hn) ++ "." ++ objectName hn --hdoc2qual :: HasHDocName a => a -> HsQName --hdoc2qual obj = Qual (Module (modulename obj)) (thename obj) --hdoc2unqual :: HasHDocName a => a -> HsQName --hdoc2unqual obj = UnQual (thename obj) unqualHsQName :: HsQName -> String unqualHsQName = hsQNameToString . unqual unqual :: HsQName -> HsQName unqual n@(UnQual _) = n unqual (Qual _ hsn) = UnQual hsn unqualHSN :: HsQName -> HsName unqualHSN (Qual _ hsn) = hsn unqualHSN (UnQual hsn) = hsn hsQNameToString :: HsQName -> String hsQNameToString (Qual (Module m) n) = m ++ ('.' : hsNameToString n) hsQNameToString (UnQual n) = hsNameToString n hsNameToString :: HsName -> String hsNameToString (HsIdent n) = n hsNameToString (HsSymbol n) = n hsNameToString (HsSpecial n) = n mapHSN :: (String -> String) -> HsName -> HsName mapHSN f (HsIdent n) = HsIdent (f n) mapHSN f (HsSymbol n) = HsSymbol (f n) mapHSN f (HsSpecial n) = HsSpecial (f n) -- make a HsQName from a String. -- "(Prelude..)", "Predule..", and "." should return -- Qual (Module "Prelude") ".", Qual (Module "Prelude") ".", and UnQual "." ! hsQNameFromString :: String -> HsQName hsQNameFromString "" = UnQual (HsIdent "") hsQNameFromString name@(n:ns) | n == '(' && last ns == ')' = if all (==',') inner then UnQual (HsSpecial name) else hsQNameFromString (take (length ns - 1) ns) | isUpper n || n == '_' = case elemIndex '.' name of Nothing -> UnQual (HsIdent name) Just i -> let (mod, _:obj) = splitAt i name hsn = case obj of x:_ -> if isLower x || x == '_' then HsIdent name else HsSymbol name _ -> HsSymbol name in Qual (Module mod) hsn | isLower n = UnQual (HsIdent name) | otherwise = UnQual (HsSymbol name) where inner = take (length ns - 1) ns mkHDocName :: ModuleDoc -> HsQName -> SrcLoc -> ModuleDoc -> HDocName mkHDocName mod hsn loc srcMod = HN { objectModule=mod, objectName=unqualHsQName hsn, srcLocation=loc, srcModule = srcMod } -- ExportFunction is only for toplevel functions or for class members; -- functions belonging to an instance declaration have to be found -- differently. data Export = ExportFunction FunctionDoc | ExportData DataDoc [ConstructorDoc] | ExportClass ClassDoc [FunctionDoc] | ExportInstance InstanceDoc | ExportType TypeDoc (Maybe Type) deriving (Eq, Show) data Import = Import Bool ModuleDoc String [Export] deriving Eq instance Show Import where show (Import qual md n incl) = "Import{" ++ show qual ++ ",\"" ++ moduleName md ++ "\",\"" ++ n ++ "\"," ++ show incl ++ "}" data PackageDoc = PackageDoc { packageName :: String, containedModules :: [ModuleDoc] } data ModuleDoc = ModuleDoc { moduleName :: String, descriptionM :: HDocText, authorM :: HDocText, versionM :: HDocText, seeTagsM :: [HDR], exports :: [Export], imports :: [Import], functions :: [FunctionDoc], datatypes :: [DataDoc], classes :: [ClassDoc], instances :: [InstanceDoc], typesynonyms :: [TypeDoc], appearsM :: Bool, hiddenM :: Bool } deriving (Show) instance Eq ModuleDoc where a == b = moduleName a == moduleName b instance HasDescription ModuleDoc where description = descriptionM instance CanAppear ModuleDoc where appearsInOutput = appearsM setAppearance md a = md { appearsM = a } instance HasSeeTags ModuleDoc where seeTags = seeTagsM data FunctionDoc = FunctionDoc { nameF :: HDocName, descriptionF :: HDocText, seeTagsF :: [HDR], signature :: Maybe Type, paramlist :: [(Typed, HDocText)], retdescr :: Maybe (Maybe Typed, HDocText, RetType), funclass :: FunClass, origSig :: Maybe Type, -- unchanged signature appearsF :: Bool, reexportF :: ModuleDoc -> FunctionDoc } instance Show FunctionDoc where show fd = show (nameF fd, signature fd, funclass fd, origSig fd, appearsF fd) instance Eq FunctionDoc where a == b = nameF a == nameF b && funclass a == funclass b instance HasHDocName FunctionDoc where hdocName = nameF instance HasDescription FunctionDoc where description = descriptionF instance CanAppear FunctionDoc where appearsInOutput = appearsF setAppearance fd a= fd { appearsF = a } instance Reexportable FunctionDoc where reexport = reexportF instance HasSeeTags FunctionDoc where seeTags = seeTagsF data ConstructorDoc = ConstructorDoc Constructor HDocText deriving Show instance Eq ConstructorDoc where ConstructorDoc c1 _ == ConstructorDoc c2 _ = c1 == c2 data DataDoc = DataDoc { nameD :: HDocName, descriptionD :: HDocText, seeTagsD :: [HDR], typedefD :: Type, derivedInstances :: [String], constructors :: [ConstructorDoc], isNewType :: Bool, appearsD :: Bool, reexportD :: ModuleDoc -> DataDoc } instance Show DataDoc where show dd = "DataDoc{nameD=\"" ++ show (nameD dd) ++ "\",appearsD=" ++ show (appearsD dd) ++ "}" instance Eq DataDoc where a == b = hdocName a == hdocName b instance HasHDocName DataDoc where hdocName = nameD instance HasDescription DataDoc where description = descriptionD instance HasTypedef DataDoc where typedef = typedefD instance CanAppear DataDoc where appearsInOutput = appearsD setAppearance dd a = dd { appearsD = a } instance Reexportable DataDoc where reexport = reexportD instance HasSeeTags DataDoc where seeTags = seeTagsD data ClassDoc = ClassDoc { nameC :: HDocName, descriptionC :: HDocText, seeTagsC :: [HDR], typedefC :: Type, functionalDeps :: [FunDep], memberFunctions :: [FunctionDoc], appearsC :: Bool, reexportC :: ModuleDoc -> ClassDoc } type FunDep = ([String],[String]) instance Eq ClassDoc where a == b = hdocName a == hdocName b instance Show ClassDoc where show a = "ClassDoc{nameC=\"" ++ show (nameC a) ++ "\",descriptionC=\"" ++ show (descriptionC a) ++ "\",typdefC=" ++ show (typedefC a) ++ ",appearsC=" ++ show (appearsC a) ++ ",memberFunctions=" ++ show (map nameF (memberFunctions a)) ++ "}" instance HasHDocName ClassDoc where hdocName = nameC instance HasDescription ClassDoc where description = descriptionC instance HasTypedef ClassDoc where typedef = typedefC instance CanAppear ClassDoc where appearsInOutput = appearsC setAppearance cd a = cd { appearsC = a } instance Reexportable ClassDoc where reexport = reexportC instance HasSeeTags ClassDoc where seeTags = seeTagsC data InstanceDoc = InstanceDoc { nameI :: HDocName, descriptionI :: HDocText, seeTagsI :: [HDR], typedefI :: Type, instanceFunctions :: [FunctionDoc], definingClass :: Maybe ClassDoc, appearsI :: Bool, reexportI :: ModuleDoc -> InstanceDoc } instance Eq InstanceDoc where a == b = hdocName a == hdocName b && typedefI a == typedefI b instance Show InstanceDoc where show a = "InstanceDoc{nameI=\"" ++ show (nameI a) ++ "\",descriptionI=\"" ++ show(descriptionI a) ++ "\",typdefI=" ++ show (typedefI a) ++ ",instanceFunctions=" ++ show (map nameF (instanceFunctions a)) ++ "}" instance HasHDocName InstanceDoc where hdocName = nameI instance HasDescription InstanceDoc where description = descriptionI instance HasTypedef InstanceDoc where typedef = typedefI instance CanAppear InstanceDoc where appearsInOutput = appearsI setAppearance id a = id { appearsI = a } instance Reexportable InstanceDoc where reexport = reexportI instance HasSeeTags InstanceDoc where seeTags = seeTagsI data TypeDoc = TypeDoc { nameT :: HDocName, typedefT :: Type, constructorT :: Type, descriptionT :: HDocText, seeTagsT :: [HDR], appearsT :: Bool, reexportT :: ModuleDoc -> TypeDoc } instance Eq TypeDoc where a == b = hdocName a == hdocName b instance Show TypeDoc where show a = "TypeDoc{nameT=\"" ++ show (nameT a) ++ "\",typedefT=\"" ++ show (typedefT a) ++ "\",constructorT=\"" ++ show (constructorT a) ++ "\",appearsT=" ++ show (appearsT a) ++ "}" instance HasHDocName TypeDoc where hdocName = nameT instance HasTypedef TypeDoc where typedef = typedefT instance HasDescription TypeDoc where description = descriptionT instance CanAppear TypeDoc where appearsInOutput = appearsT setAppearance td a = td { appearsT = a } instance Reexportable TypeDoc where reexport = reexportT instance HasSeeTags TypeDoc where seeTags = seeTagsT thename :: HasHDocName a => a -> String thename obj = objectName (hdocName obj) themodule :: HasHDocName a => a -> ModuleDoc themodule = objectModule . hdocName modulename :: HasHDocName a => a -> String modulename obj = moduleName $ objectModule (hdocName obj) fullname :: HasHDocName a => a -> String fullname obj = modulename obj ++ ('.' : thename obj) lineNumber :: HasHDocName a => a -> Integer lineNumber obj = fromIntegral line where SrcLoc line _ = srcLocation (hdocName obj) data TypeId = TyUnknown | TyVar | TyType TypeDoc | TyData DataDoc | TyClass ClassDoc deriving Eq {- instance Reexportable TypeId where reexport TyUnknown _ = TyUnknown reexport (TyType t) md = TyType (reexport t md) reexport (TyData d) md = TyData (reexport d md) reexport (TyClass c) md = TyClass (reexport c md) -} instance Show TypeId where show TyUnknown = "TyUnknown" show TyVar = "TyVar" show (TyType t) = fullname t show (TyData d) = fullname d show (TyClass c) = fullname c data Constructor = Constructor String [String] (Maybe Type) [Typed] [Type] | Labelled String [Typed] deriving (Show) instance Eq Constructor where c1 == c2 = constructorName c1 == constructorName c2 constructorName :: Constructor -> String constructorName (Labelled n _) = n constructorName (Constructor n _ _ _ _) = n data Type = Simple (HsQName, TypeId) | Con (HsQName, TypeId) [Type] | List Type | Tuple [Type] | Fun Type Type | Context Type Type | Forall [String] Type deriving (Eq, Show) simpleShowType :: Type -> String simpleShowType (Simple (hsn,_)) = hsQNameToString hsn simpleShowType (Context t1 t2) = simpleShowType t1 ++ " => " ++ simpleShowType t2 simpleShowType (List t) = "[" ++ simpleShowType t ++ "]" simpleShowType (Tuple ts) = "(" ++ concat (intersperse ", " (map simpleShowType ts)) ++ ")" simpleShowType (Fun t1 t2) = simpleShowType t1 ++ " -> (" ++ simpleShowType t2 ++ ")" simpleShowType (Con (hsn,_) ts) = hsQNameToString hsn ++ concat (intersperse " " ["(" ++ s ++ ")" | s <- map simpleShowType ts]) simpleShowType (Forall vs t) = "(forall" ++ concat [' ':v | v <- vs] ++ "." ++ simpleShowType t ++ ")" relookupType :: ModuleDoc -> Type -> Type relookupType md (Simple (n, tyid)) = Simple (newName, tyid') where tyid' = relookupTyId md tyid newName = nameAfterRelookup n tyid' relookupType md (Con (n, tyid) ts) = Con (newName, tyid') ts' where tyid' = relookupTyId md tyid ts' = map (relookupType md) ts newName = nameAfterRelookup n tyid' relookupType md (List t) = List (relookupType md t) relookupType md (Tuple ts) = Tuple (map (relookupType md) ts) relookupType md (Fun t1 t2) = Fun (relookupType md t1) (relookupType md t2) relookupType md (Context t1 t2) = Context (relookupType md t1) (relookupType md t2) relookupType md (Forall vs t) = Forall vs (relookupType md t) nameAfterRelookup :: HsQName -> TypeId -> HsQName nameAfterRelookup n@(UnQual _) _ = n nameAfterRelookup n@(Qual _ hsn) tyid = case tyid of TyType t -> qual t --hdoc2qual t TyData d -> qual d --hdoc2qual d TyClass c -> qual c --hdoc2qual c _ -> n where qual :: HasHDocName a => a -> HsQName qual obj = Qual (Module $ modulename obj) hsn' where hsn' = mapHSN (\_ -> thename obj) hsn relookupTyId :: ModuleDoc -> TypeId -> TypeId relookupTyId _ TyUnknown = TyUnknown relookupTyId _ TyVar = TyVar relookupTyId md (TyClass c) = case relookupClass md c of Just c' -> TyClass c' Nothing -> TyClass c --TyUnknown relookupTyId md (TyData d) = case relookupData md d of Just d' -> TyData d' Nothing -> TyData d --TyUnknown relookupTyId md (TyType t) = case relookupTypeDoc md t of Just t' -> TyType t' Nothing -> TyType t --TyUnknown relookupFunClass :: ModuleDoc -> FunClass -> FunClass relookupFunClass _ NoClass = NoClass relookupFunClass md (Class c) = case relookupClass md c of Just c' -> Class c' Nothing -> NoClass relookupFunClass md (Instance i) = case relookupInstance md i of Just i' -> Instance i' Nothing -> NoClass data Typed = Typed Typed Type | ContextT Typed Typed | SimpleT String | ConT String [Typed] | ListT Typed | TupleT [Typed] | FunT Typed Typed deriving (Eq, Show) extractType :: Typed -> Type extractType (Typed _ t) = t extractType (ContextT ty1 ty2) = Context (extractType ty1) (extractType ty2) extractType (SimpleT n) = Simple (UnQual (HsIdent "?"), TyUnknown) extractType (ConT n tys) = Con (UnQual (HsIdent "?"), TyUnknown) (map extractType tys) extractType (ListT ty) = List (extractType ty) extractType (TupleT tys) = Tuple (map extractType tys) extractType (FunT ty1 ty2) = Fun (extractType ty1) (extractType ty2) addType :: Typed -> Type -> Typed addType ty t | hasTypeSig ty = ty | otherwise = Typed ty t where hasTypeSig :: Typed -> Bool hasTypeSig (Typed _ _) = True hasTypeSig (ContextT _ ty) = hasTypeSig ty hasTypeSig (SimpleT _) = False hasTypeSig (ConT _ tys) = or (map hasTypeSig tys) hasTypeSig (ListT ty) = hasTypeSig ty hasTypeSig (TupleT tys) = or (map hasTypeSig tys) hasTypeSig (FunT ty1 ty2) = hasTypeSig ty1 || hasTypeSig ty2 addTypes :: FunctionDoc -> [(Typed,HDocText)] -> Maybe (Maybe Typed, HDocText, RetType) -> Type -> ([(Typed,HDocText)],Maybe (Maybe Typed, HDocText, RetType)) addTypes fd [] Nothing t = ([], Nothing) addTypes fd p r t = addTypes' p r t where addTypes' [] Nothing t = ([], Just (Just (Typed (SimpleT "_") t), [], Functional)) addTypes' [] (Just (Nothing, desc, Functional)) t = ([], Just (Just (Typed (SimpleT "_") t), desc, Functional)) addTypes' [] (Just (Nothing, desc, Monadic)) t = ([], Just (Just (Typed (SimpleT "_") (monadic t)), desc, Monadic)) addTypes' [] (Just (Just ty, desc, Monadic)) t = ([], Just (Just (addType ty (monadic t)), desc, Monadic)) addTypes' [] (Just (Just ty, desc, Functional)) t = ([], Just (Just (addType ty t), desc, Functional)) addTypes' p r (Context _ t) = addTypes' p r t addTypes' ((ty,desc) : ps) r (Fun t1 t2) = let (p', r') = addTypes' ps r t2 in ((addType ty t1, desc):p', r') addTypes' ps r _ = --(ps, r) error ("more @params than curried function arguments for\n " ++ moduleName (srcModule $ hdocName fd) ++ "." ++ thename fd ++ " in line " ++ show l) -- for @monadic make things like "IO a" to "a" monadic :: Type -> Type monadic (Context t1 t2) = Context t1 (monadic t2) monadic (Con _ [t]) = t monadic _ = error ("monadic: the type of " ++ moduleName (srcModule $ hdocName fd) ++ "." ++ thename fd ++ " in line " ++ show l ++ "\n is not suitable for a monadic function") SrcLoc l _ = srcLocation (hdocName fd) checkTycons :: Type -> Type checkTycons t@(Simple _) = t checkTycons (Context t1 t2) = Context (checkTycons t1) (checkTycons t2) checkTycons (Tuple ts) = Tuple (map checkTycons ts) checkTycons (Fun t1 t2) = Fun (checkTycons t1) (checkTycons t2) checkTycons (List t) = List (checkTycons t) checkTycons t@(Con n@(UnQual (HsIdent "[]"), TyUnknown) ts) = case ts of [] -> Con n (map checkTycons ts) [t2] -> List (checkTycons t2) _ -> error (simpleShowType t ++ "\n is not an allowed type") checkTycons t@(Con n@(UnQual (HsIdent "->"), TyUnknown) ts) = case ts of [] -> Con n (map checkTycons ts) [_] -> Con n (map checkTycons ts) [t1,t2] -> Fun (checkTycons t1) (checkTycons t2) _ -> error (simpleShowType t ++ "\n is not an allowed type") checkTycons t@(Con n@(UnQual hsn, tyid) ts) | comps == -1 = Con n (map checkTycons ts) | comps < length ts = Con n (map checkTycons ts) | comps == length ts && tyid == TyUnknown = Tuple (map checkTycons ts) | otherwise = error (simpleShowType t ++ "\n is not an allowed type") where -- calculate the number of components required in the tuple constructor -- () -> 0 -- (,) -> 2 -- (,,) -> 3 -- ... -- (return -1 if `n' does not represent a tuple constructor) comps = case hsn of (HsSpecial "()") -> 0 (HsSpecial ('(':xs)) -> f xs 1 _ -> -1 f "" _ = -1 f ")" c = c f (',':xs) c = f xs (c+1) f _ _ = -1 checkTycons (Con n ts) = Con n (map checkTycons ts) checkTycons (Forall vs t) = Forall vs (checkTycons t) substType :: Type -> Type -> Type -> Maybe Type substType t1 t2 t3 = case substType' t1 t2 t3 of Just t -> Just (checkTycons t) Nothing -> Nothing substType' :: Type -> Type -> Type -> Maybe Type substType' (Context _ t) it ft = substType' t it ft substType' ct (Context icon it) ft = case substType' ct it ft of Nothing -> Nothing Just t -> Just (Context icon t) substType' (Tuple cts) (Tuple its) ft | length cts == length its = foldl (>>=) (Just ft) [substType' c i | (c,i) <- zip cts its] | otherwise = Nothing substType' (Fun ct1 ct2) (Fun it1 it2) ft = substType' ct1 it1 ft >>= substType' ct2 it2 substType' (List ct) (List it) ft = substType' ct it ft substType' (Con (ccn,_) cts) (Con (icn,tyid) its) ft | length cts == length its = foldl (>>=) (Just $ substName ccn (icn,tyid) ft) [substType' c i | (c,i) <- zip cts its] | otherwise = Nothing substType' (Simple (ccn,_)) (Simple (icn,tyid)) ft = Just $ substName ccn (icn,tyid) ft substType' (Simple (ccn,_)) t ft = Just $ substComplex ccn t ft substType' ct it ft = Nothing -- error ("substType' " ++ show (ct, it, ft)) substComplex :: HsQName -> Type -> Type -> Type substComplex ccn ity = replace where replace (Context t1 t2) = Context (replace t1) (replace t2) replace (Tuple ts) = Tuple (map replace ts) replace (Fun t1 t2) = Fun (replace t1) (replace t2) replace (List t) = List (replace t) replace (Con c ts) = Con c (map replace ts) replace (s @ (Simple (n,tyid))) | n == ccn = ity | otherwise = s replace (Forall vs t) | null vs' = replace t | otherwise = Forall vs' (replace t) where vs' = case ccn of UnQual (HsIdent i) -> vs \\ [i] _ -> vs substName :: HsQName -> (HsQName,TypeId) -> Type -> Type substName ccn (icn,icnId) = replace where replace (Context t1 t2) = Context (replace t1) (replace t2) replace (Tuple ts) = Tuple (map replace ts) replace (Fun t1 t2) = Fun (replace t1) (replace t2) replace (List t) = List (replace t) replace (Con (n,tyid) ts) | n == ccn = Con (icn,icnId) (map replace ts) | otherwise = Con (n,tyid) (map replace ts) replace (s @ (Simple (n,tyid))) | n == ccn = Simple (icn,icnId) | otherwise = s replace (Forall vs t) | null vs' = replace t | otherwise = Forall vs' (replace t) where vs' = case ccn of UnQual (HsIdent i) -> vs \\ [i] _ -> vs -- extract the "base name" from a (complex) type; -- for example the ctypeName of "Eq a => IO (Maybe a)" -- is "IO". For lists, tuples and functions -- ("[Int]", "(Double, a)", "a -> b") -- ctypeName is undefined and returns "???" ctypeName :: Type -> HsQName ctypeName (Context _ (Simple (n,_))) = n ctypeName (Context _ (Con (n,_) _)) = n ctypeName (Simple (n,_)) = n ctypeName (Con (n,_) _) = n ctypeName _ = UnQual (HsIdent "???") {- -- this was used by the parser some versions ago; perhapes we can use it -- again in the future ? data StateMonad a b = SM (a -> (a, b)) returnStM :: b -> StateMonad a b returnStM x = SM (\a -> (a,x)) thenStM :: StateMonad a b -> (b -> StateMonad a c) -> StateMonad a c thenStM (SM f) g = SM (\a -> ((\(a', b') -> (\(SM h) -> h a') (g b')) (f a))) instance Monad (StateMonad a) where return = returnStM (>>=) = thenStM startStM :: a -> StateMonad a b -> (a, b) startStM a (SM f) = f a setState :: a -> StateMonad a () setState a = SM (\_ -> (a, ())) getState :: StateMonad a a getState = SM (\a -> (a,a)) mapState :: (a -> a) -> StateMonad a () mapState f = SM (\a -> (f a, ())) currentModule :: StateMonad ParserState ModuleDoc currentModule = liftM curMod getState currentClass :: StateMonad ParserState FunClass currentClass = liftM curClass getState -} appears :: HDocSettings -> ModuleDoc -> Export -> Bool appears _ _ (ExportFunction (FunctionDoc {funclass=Instance _})) = True appears hdSet md e | hdsExportsOnly hdSet = appearsInOutput md && or [isExp e e2 | e2 <- exports md] | otherwise = appearsInOutput md where isExp (ExportType t1 _) (ExportType t2 _) = t1 == t2 isExp (ExportData d1 _) (ExportData d2 _) = d1 == d2 isExp (ExportClass c1 _) (ExportClass c2 _) = c1 == c2 isExp (ExportInstance i1) (ExportInstance i2) = i1 == i2 isExp (ExportFunction f1) (ExportFunction f2) = f1 == f2 isExp _ _ = False -- lookup functions lookupClass :: ModuleDoc -> HsQName -> Maybe ClassDoc lookupClass md hsn = case lookupExportClass md hsn of Just (ExportClass c _) -> Just c _ -> Nothing -- instances are only looked for locally! lookupInstance :: ModuleDoc -> Type -> Maybe InstanceDoc lookupInstance md ty = listToMaybe [i | i <- instances md, typedef i == ty] relookupInstance :: ModuleDoc -> InstanceDoc -> Maybe InstanceDoc relookupInstance md i = listToMaybe $ [i' | i' <- instances md, i == i'] ++ [i' | Import _ _ _ exps <- imports md, ExportInstance i' <- exps, i == i'] -- all (known) instances of class `cd' knownInstances :: HDocInput -> ClassDoc -> [InstanceDoc] knownInstances hdInp cd = nub $ [i | md <- allModules hdInp, i <- instances md, definingClass i == Just cd] -- [i | i <- instances (themodule cd), definingClass i == Just cd] ++ -- [i | Import _ _ _ exps <- imports (themodule cd), ExportInstance i <- exps, -- definingClass i == Just cd] {- -- all visible instances of class `cd' knownVisiInsts :: HDocInput -> ClassDoc -> [InstanceDoc] knownVisiInsts hdInp cd = [i | i <- knownInstances hdInp cd, isExp (typedef i)] where md = themodule cd exps = exports md isExp (Context t1 t2) = isExp t1 && isExp t2 isExp (Simple (_,tyid)) = isExpTyid tyid isExp (Fun t1 t2) = isExp t1 && isExp t2 isExp (List t) = isExp t isExp (Tuple ts) = all isExp ts isExp (Con (_,tyid) ts) = isExpTyid tyid && all isExp ts isExpTyid TyUnknown = False isExpTyid TyVar = True isExpTyid (TyClass c) = or [c == c' | ExportClass c' _ <- exps] isExpTyid (TyData d) = or [d == d' | ExportData d' _ <- exps] isExpTyid (TyType t) = or [t == t' | ExportType t' _ <- exps] -} -- extract the summary from a description (this is simply the first -- sentence, ie. the text upto the first "."); needs some fixing so that -- the first "sentence" can expand over the first apperance of a "." . summary :: HasDescription a => a -> HDocText summary hasdesc = f (description hasdesc) where f [] = [] f (t@(HdeText str) : xs) = case elemIndex '.' str of Nothing -> t : f xs Just idx -> [HdeText (take (idx+1) str)] f (x : xs) = x : f xs -- return the exports list for all local objects localExports :: ModuleDoc -> [Export] localExports (ModuleDoc {functions=fs, datatypes=ds, typesynonyms=ts, classes=cs, instances=is}) = [ExportFunction f | f <- fs, notInInstance f] ++ [ExportType t (Just $ constructorT t) | t <- ts] ++ [ExportClass c (memberFunctions c) | c <- cs] ++ [ExportData d (constructors d) | d <- ds] ++ [ExportInstance i | i <- is] notInInstance :: FunctionDoc -> Bool notInInstance fd = case funclass fd of Instance _ -> False _ -> True -- constuct the export list for a module which has no explicit export list allExports :: ModuleDoc -> [Export] allExports md = localExports md ++ [e | Import _ _ _ exps <- imports md, e <- exps] -- calculate the signature of a function belonging to an instance -- declaration from that declaration and the signature of the function -- as defined in the class (ie. substitute the concrete type(s) for the -- type variable(s) etc.) signatureFromClass :: HsQName -> FunClass -> Maybe Type signatureFromClass hsn (Instance id) = case fs of [] -> Nothing (f,cl):_ -> origSig f >>= substType (typedef cl) (typedef id) where fs = case definingClass id of Nothing -> [] Just cd -> [(f,cd) | f <- memberFunctions cd, localNameMatch f hsn] signatureFromClass _ _ = Nothing -- add the context that a class declration implies to the type t. -- For example "a -> Int" with a class declaration like "class X a" -- becomes "X a => a -> Int" joinContext :: Type -> FunClass -> Type joinContext t (Class cd) = case typedef cd of (Context _ tt) -> joinC tt t tt -> joinC tt t where joinC tt (Context (Tuple x) y) = Context (Tuple (tt:x)) y joinC tt (Context x y) = Context (Tuple [tt,x]) y joinC tt t = Context tt t joinContext t _ = t -- find all functions having the given FunClass members :: ModuleDoc -> FunClass -> [FunctionDoc] members mod fclass = [f | f <- functions mod, funclass f == fclass] ++ nub [f | Import _ _ _ es <- imports mod, ExportFunction f <- es, funclass f == fclass] relookupClass :: ModuleDoc -> ClassDoc -> Maybe ClassDoc relookupClass md c = listToMaybe $ [c' | c' <- classes md, c == c'] ++ [c' | Import _ _ _ exps <- imports md, ExportClass c' _ <- exps, c == c'] relookupData :: ModuleDoc -> DataDoc -> Maybe DataDoc relookupData md d = listToMaybe $ [d' | d' <- datatypes md, d == d'] ++ [d' | Import _ _ _ exps <- imports md, ExportData d' _ <- exps, d == d'] relookupTypeDoc :: ModuleDoc -> TypeDoc -> Maybe TypeDoc relookupTypeDoc md t = listToMaybe $ [t' | t' <- typesynonyms md, t == t'] ++ [t' | Import _ _ _ exps <- imports md, ExportType t' _ <- exps, t == t'] lookupTypeId :: ModuleDoc -> HsQName -> (HsQName, TypeId) lookupTypeId md hqsn = (hqsn, tyid) where tyid = case lookupExport md hqsn of Just (ExportClass c _) -> TyClass c Just (ExportData d _) -> TyData d Just (ExportType t _) -> TyType t _ -> case hqsn of UnQual (HsIdent (n:_)) -> if isLower n then TyVar else TyUnknown _ -> TyUnknown lookupExportData :: ModuleDoc -> HsQName -> Maybe Export lookupExportData md hsn = case (localDs, impDs) of (d:_, _ ) -> Just $ ExportData d (constructors d) ([], ed:_) -> Just ed ([], [] ) -> Nothing where localDs = [d | d <- datatypes md, localNameMatch d hsn] impDs = [ed | Import qual _ qn exps <- imports md, (ed@(ExportData d _)) <- exps, doNamesMatch qual qn hsn d] lookupExportType :: ModuleDoc -> HsQName -> Maybe Export lookupExportType md hsn = case (localTs, impTs) of (t:_, _ ) -> Just $ ExportType t (Just $ typedef t) ([], et:_) -> Just $ et ([], [] ) -> Nothing where localTs = [t | t <- typesynonyms md, localNameMatch t hsn] impTs = [et | Import qual _ qn exps <- imports md, (et@(ExportType t _)) <- exps, doNamesMatch qual qn hsn t] lookupExportClass :: ModuleDoc -> HsQName -> Maybe Export lookupExportClass md hsn = case (localCs, impCs) of (c:_, _ ) -> Just $ ExportClass c (memberFunctions c) ([], ec:_) -> Just $ ec ([], [] ) -> Nothing where localCs = [c | c <- classes md, localNameMatch c hsn] impCs = [ec | Import qual _ qn exps <- imports md, (ec@(ExportClass c _)) <- exps, doNamesMatch qual qn hsn c] lookupExportFunction :: ModuleDoc -> HsQName -> Maybe Export lookupExportFunction md hsn = case (localFs, impFs) of (f:_, _ ) -> Just $ ExportFunction f ([], ef:_) -> Just $ ef ([], [] ) -> Nothing where localFs = [f | f <- functions md, notInInstance f, localNameMatch f hsn] impFs = [ef | Import qual _ qn exps <- imports md, (ef@(ExportFunction f)) <- exps, notInInstance f, doNamesMatch qual qn hsn f] localNameMatch :: HasHDocName a => a -> HsQName -> Bool localNameMatch obj (Qual (Module m) hsn) = hsNameToString hsn == thename obj && m == moduleName (themodule obj) localNameMatch obj (UnQual hsn) = hsNameToString hsn == thename obj -- Bool param: qualified name required? doNamesMatch :: HasHDocName a => Bool -> String -> HsQName -> a -> Bool doNamesMatch False qn (UnQual hsn) o = hsNameToString hsn == thename o doNamesMatch _ qn (Qual (Module m) hsn) o = m == qn && hsNameToString hsn == thename o doNamesMatch True _ (UnQual _) _ = False prefixname :: HasHDocName a => a -> String prefixname hd | n == "" = n | head n `elem` ":!#$%&*+./<=>?@\\^|-~" = '(':n ++ ")" | otherwise = n where n = thename hd lookupExport :: ModuleDoc -> HsQName -> Maybe Export lookupExport md hsn | startsWithCapital = listToMaybe ((maybeToList $ lookupExportData md hsn) ++ (maybeToList $ lookupExportType md hsn) ++ (maybeToList $ lookupExportClass md hsn)) | otherwise = lookupExportFunction md hsn where startsWithCapital = case hsn of UnQual n -> swc (hsNameToString n) Qual (Module _) n -> swc (hsNameToString n) swc "" = False swc ('_':xs) = swc xs swc (x:_) = isUpper x data GeneralTags = GenT { gtDescription :: HDocText, gtSee :: [String] } deriving Show data MT = MT { mtAuthor :: HDocText, mtVersion :: HDocText } deriving Show data FT = FT { ftParam :: [(Typed, HDocText)], ftReturn :: (Maybe (Maybe Typed, HDocText, RetType)) } deriving Show data DT = DT { dtCons :: [ConstructorDoc] } deriving Show data SpecialTags = ModuleTags MT | DataTags DT | FunctionTags FT | TypeTags | ClassInstTags | ConstructorTags deriving Show data HDoc = HDoc GeneralTags SpecialTags deriving Show emptyGenTags :: GeneralTags emptyGenTags = GenT { gtDescription = [], gtSee = [] } emptyModuleTags :: MT emptyModuleTags = MT { mtAuthor = [], mtVersion = [] } emptyFunctionTags :: FT emptyFunctionTags = FT { ftParam = [], ftReturn = Nothing } emptyDataTags :: DT emptyDataTags = DT { dtCons = [] } data CommentAssoc = Positional Loc | PerName HsQName [HDoc] -- the Loc thing can be implemented better (faster), -- but it works for now data Loc = HDocLoc { locSrcLoc :: SrcLoc, locHDoc :: [HDoc] } | HDocConsLoc { locSrcLoc :: SrcLoc, locHDoc :: [HDoc] } | ModuleLoc { locSrcLoc :: SrcLoc } | DeclLoc { locSrcLoc :: SrcLoc } | ConsLoc { locSrcLoc :: SrcLoc } deriving (Show) srcLocLT :: SrcLoc -> SrcLoc -> Bool srcLocLT (SrcLoc y1 x1) (SrcLoc y2 x2) = y1 < y2 || (y1 == y2 && x1 < x2) srcLocLEQ :: SrcLoc -> SrcLoc -> Bool srcLocLEQ (SrcLoc y1 x1) (SrcLoc y2 x2) = y1 <= y2 || (y1 == y2 && x1 <= x2)