1 files changed, 138 insertions, 0 deletions
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
new file mode 100644
index 00000000..51c31438
--- /dev/null
+++ b/src/HaddockUtil.hs
@@ -0,0 +1,138 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) The University of Glasgow 2001-2002
+-- (c) Simon Marlow 2002
+--
+
+module HaddockUtil (
+
+  -- * Misc utilities
+  nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
+  restrictTo,
+
+  -- * Filename utilities
+  basename, dirname, splitFilename3, 
+  isPathSeparator, pathSeparator
+
+ ) where
+
+import HsSyn
+import List (intersect)
+
+-- -----------------------------------------------------------------------------
+-- Some Utilities
+
+nameOfQName (Qual _ n) = n
+nameOfQName (UnQual n) = n
+
+collectNames :: [HsDecl] -> [HsName]
+collectNames ds = concat (map declBinders ds)
+
+declMainBinder :: HsDecl -> Maybe HsName
+declMainBinder d = 
+   case d of
+     HsTypeDecl _ n _ _          -> Just n
+     HsDataDecl _ _ n _ cons _   -> Just n
+     HsNewTypeDecl _ _ n _ _ _   -> Just n
+     HsClassDecl _ qt decls      -> Just (exQtNm qt)
+     HsTypeSig _ [n] _           -> Just n
+     HsTypeSig _ ns _            -> error "declMainBinder"
+     HsForeignImport _ _ _ _ n _ -> Just n
+     _                           -> Nothing
+
+declBinders :: HsDecl -> [HsName]
+declBinders d =
+   case d of
+     HsTypeDecl _ n _ _          -> [n]
+     HsDataDecl _ _ n _ cons _   -> n : concat (map conDeclBinders cons)
+     HsNewTypeDecl _ _ n _ _ _   -> [n]
+     HsClassDecl _ qt decls      -> exQtNm qt : collectNames decls
+     HsTypeSig _ ns _            -> ns
+     HsForeignImport _ _ _ _ n _ -> [n]
+     _                           -> []
+
+conDeclBinders (HsConDecl _ n _ _) = [n]
+conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
+
+fieldDeclBinders (HsFieldDecl ns _ _) = ns
+
+exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
+exQtNm t = nameOfQName (fst (splitTyConApp t))
+
+splitTyConApp :: HsType -> (HsQName,[HsType])
+splitTyConApp t = split t []
+ where
+	split :: HsType -> [HsType] -> (HsQName,[HsType])
+	split (HsTyApp t u) ts = split t (u:ts)
+	split (HsTyCon t)   ts = (t,ts)
+	split _ _ = error "splitTyConApp"
+
+-- ---------------------------------------------------------------------------
+-- Making abstract declarations
+
+restrictTo :: [HsName] -> HsDecl -> HsDecl
+restrictTo names decl = case decl of
+     HsDataDecl loc ctxt n xs cons drv -> 
+	HsDataDecl loc ctxt n xs (restrictCons names cons) drv
+     HsNewTypeDecl loc ctxt n xs con drv ->
+	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	
+     HsClassDecl loc qt decls  ->
+	HsClassDecl loc qt (restrictDecls names decls)
+     _ -> decl
+   
+restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
+restrictCons names decls = filter keep decls
+  where keep (HsConDecl _ n _ _) = n `elem` names
+	keep (HsRecDecl _ n _ _) = n `elem` names
+	-- ToDo: records not right
+
+restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
+restrictDecls names decls = filter keep decls
+  where keep d = not (null (declBinders d `intersect` names))
+	-- ToDo: not really correct
+
+-- -----------------------------------------------------------------------------
+-- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = split_longest_prefix f (=='.')
+
+basename :: String -> String
+basename f = base where (_dir, base, _suff) = splitFilename3 f
+
+dirname :: String -> String
+dirname f = dir where (dir, _base, _suff) = splitFilename3 f
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+   = let (dir, rest) = split_longest_prefix str isPathSeparator
+	 (name, ext) = splitFilename rest
+	 real_dir | null dir  = "."
+		  | otherwise = dir
+     in  (real_dir, name, ext)
+
+split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
+split_longest_prefix s pred
+  = case pre of
+	[]      -> ([], reverse suf)
+	(_:pre) -> (reverse pre, reverse suf)
+  where (suf,pre) = break pred (reverse s)
+
+pathSeparator :: Char
+#ifdef __WIN32__
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif