Refactored HTML generation

src/Html/CurryHtml.hs

@@ -16,7 +16,6 @@ module Html.CurryHtml (source2html) where
 import Control.Monad.Writer
 import Control.Monad.Trans.Either
 
-import Data.Char             (toLower)
 import Data.Maybe            (fromMaybe, isJust)
 import System.FilePath       ((</>), dropFileName, takeBaseName)
 
@@ -24,14 +23,15 @@ import Curry.Base.Ident      (QualIdent (..), unqualify)
 import Curry.Base.Message
 import Curry.Base.Pretty     (text)
 import Curry.Files.PathUtils (readModule, lookupCurryFile)
-import Curry.Syntax          (Module, lexSource, parseModule)
+import Curry.Syntax          (Module, lexSource)
 
 import Html.SyntaxColoring
 
 import Base.Messages
-import CompilerOpts          (Options(..), TargetType (..), defaultOptions)
+import CompilerOpts          (Options (..))
 import CurryBuilder          (buildCurry)
-import Modules               (loadAndCheckModule, checkModuleHeader)
+import Modules               (loadAndCheckModule)
+import Transformations       (qual)
 
 --- translate source file into HTML file with syntaxcoloring
 --- @param sourcefilename
@@ -47,113 +47,84 @@ source2html opts f = do
 --- @param importpaths
 --- @param filename
 --- @return program
-filename2program :: Options -> String -> CYIO Program
+filename2program :: Options -> String -> CYIO [Code]
 filename2program opts f = do
   mbModule <- liftIO $ readModule f
   case mbModule of
     Nothing  -> left [message $ text $ "Missing file: " ++ f]
     Just src -> do
-      typed   <- liftIO $ fromIO $ fullParse opts f src
-      checked <- liftIO $ fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) f src
-      let parsed = parse f src
-          lexed  = lexSource f src
-      return $ genProgram src [typed, checked, parsed] lexed
-
-{- |Return the result of a syntactical analysis of the source program 'src'.
-    The result is the syntax tree of the program (type 'Module'; see Module
-    "CurrySyntax").
--}
-parse :: FilePath -> String -> MessageM Module
-parse fn src = parseModule fn src >>= genCurrySyntax
-  where
-  genCurrySyntax mod1 = do
-    checked <- lift $ runEitherT $ checkModuleHeader defaultOptions fn mod1
-    case checked of
-      Left hdrErrs -> failWith $ show $ head hdrErrs
-      Right mdl    -> return mdl
-
-{- |Return the syntax tree of the source program 'src' (type 'Module'; see
-    Module "CurrySyntax").after inferring the types of identifiers.
-    'fullParse' always searches for standard Curry libraries in the path
-    defined in the
-    environment variable "PAKCSLIBPATH". Additional search paths can
-    be defined using the argument 'paths'.
--}
-fullParse :: Options -> FilePath -> String -> MessageIO Module
+      case runMsg (lexSource f src) of
+        Left e          -> left [e]
+        Right (toks, _) -> do
+          typed <- fullParse opts f src
+          return (genProgram typed toks)
+
+-- |Return the syntax tree of the source program 'src' (type 'Module'; see
+-- Module "CurrySyntax").after inferring the types of identifiers.
+-- 'fullParse' always searches for standard Curry libraries in the path
+-- defined in the
+-- environment variable "PAKCSLIBPATH". Additional search paths can
+-- be defined using the argument 'paths'.
+fullParse :: Options -> FilePath -> String -> CYIO Module
 fullParse opts fn _ = do
-  errs <- liftIO $ makeInterfaces opts fn
-  if null errs
-    then do
-      checked <- liftIO $ runEitherT $ loadAndCheckModule opts fn
-      case checked of
-        Left errs'      -> failWith $ show $ head errs'
-        Right (_, mod') -> return mod'
-    else failWith $ show $ head errs
-
--- Generates interface files for importes modules, if they don't exist or
--- if they are not up-to-date.
-makeInterfaces :: Options -> FilePath -> IO [Message]
-makeInterfaces opts fn = do
-  res <- runEitherT $ buildCurry opts fn
-  case res of
-    Left  errs -> return errs
-    Right _    -> return []
-
+  buildCurry (opts { optTargetTypes = []}) fn
+  (env, mdl) <- loadAndCheckModule opts fn
+  return (fst $ qual opts env mdl)
 
 -- generates htmlcode with syntax highlighting
 -- @param modulname
 -- @param a program
 -- @return HTMLcode
-program2html :: String -> Program -> String
-program2html modulname codes =
-  "<html>\n<head>\n<title>Module " ++
-  modulname ++
-  "</title>\n" ++
-  "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\">" ++
-  "</link>\n</head>\n" ++
-  "<body style=\"font-family:'Courier New', Arial;\">\n<pre>\n" ++
-  concatMap (code2html True . (\ (_, _, c) -> c)) codes ++
-  "<pre>\n</body>\n</html>"
-
-code2html :: Bool -> Code -> String
-code2html ownClass code@(CodeWarning _ c) =
-  (if ownClass then spanTag (code2class code) else id) (code2html False c)
-code2html ownClass code@(Commentary _) =
-  (if ownClass then spanTag (code2class code) else id)
-    (replace '<' "<span>&lt</span>" (code2string code))
-code2html ownClass c
-  | isCall c && ownClass = maybe tag (addHtmlLink   tag) (getQualIdent c)
-  | isDecl c && ownClass = maybe tag (addHtmlAnchor tag) (getQualIdent c)
-  | otherwise            = tag
-  where tag = (if ownClass then spanTag (code2class c) else id)
-                      (htmlQuote (code2string c))
+program2html :: String -> [Code] -> String
+program2html modulname codes = unlines
+  [ "<!DOCTYPE html>"
+  , "<html>", "<head>", "<title>Module " ++ modulname ++ "</title>"
+  , "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\"/>"
+  , "</head>"
+  , "<body style=\"font-family:'Courier New', Arial;\">"
+  , "<table><tbody><tr>"
+  , "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
+  , "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
+  , "</tr></tbody></table>"
+  , "</body>"
+  , "</html>"
+  ]
+  where
+  lineHtml = unlines $ map show [1 .. length (lines codeHtml)]
+  codeHtml = concatMap code2html codes
+
+code2html :: Code -> String
+code2html code@(Commentary _) =
+  spanTag (code2class code) (replace '<' "<span>&lt</span>" (code2string code))
+code2html c
+  | isCall c  = maybe tag (addHtmlLink   tag) (getQualIdent c)
+  | isDecl c  = maybe tag (addHtmlAnchor tag) (getQualIdent c)
+  | otherwise = tag
+  where tag = spanTag (code2class c) (htmlQuote (code2string c))
 
 spanTag :: String -> String -> String
 spanTag [] str = str
 spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>"
 
--- which code has which color
+-- which code has which css class
 -- @param code
--- @return color of the code
+-- @return css class of the code
 code2class :: Code -> String
-code2class (Keyword           _) = "keyword"
-code2class (Space             _) = ""
-code2class NewLine               = ""
-code2class (ConstructorName k _) = "constructorname_"  ++ showLower k
-code2class (Function        k _) = "function_" ++ showLower k
-code2class (ModuleName        _) = "modulename"
-code2class (Commentary        _) = "commentary"
-code2class (NumberCode        _) = "numbercode"
-code2class (StringCode        _) = "stringcode"
-code2class (CharCode          _) = "charcode"
-code2class (Symbol            _) = "symbol"
-code2class (Identifier      k _) = "identifier_" ++ showLower k
-code2class (TypeConstructor k _) = "typeconstructor_" ++ showLower k
-code2class (CodeWarning     _ _) = "codewarning"
-code2class (NotParsed         _) = "notparsed"
-
-showLower :: Show a => a -> String
-showLower = map toLower . show
+code2class (Space        _) = ""
+code2class NewLine          = ""
+code2class (Keyword      _) = "keyword"
+code2class (Pragma       _) = "pragma"
+code2class (Symbol       _) = "symbol"
+code2class (TypeCons   _ _) = "type"
+code2class (DataCons   _ _) = "cons"
+code2class (Label      _ _) = "label"
+code2class (Function   _ _) = "func"
+code2class (Identifier _ _) = "ident"
+code2class (ModuleName   _) = "module"
+code2class (Commentary   _) = "comment"
+code2class (NumberCode   _) = "number"
+code2class (StringCode   _) = "string"
+code2class (CharCode     _) = "char"
 
 replace :: Char -> String -> String -> String
 replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) ""
@@ -174,27 +145,22 @@ addHtmlLink str qid =
    "</a>"
 
 isCall :: Code -> Bool
-isCall (TypeConstructor TypeExport _) = True
-isCall (TypeConstructor          _ _) = False
-isCall (Identifier               _ _) = False
-isCall code = not (isDecl code) && isJust (getQualIdent code)
+isCall (TypeCons TypeExport _) = True
+isCall (TypeCons TypeImport _) = True
+isCall (TypeCons TypeRefer  _) = True
+isCall (TypeCons          _ _) = False
+isCall (Identifier        _ _) = False
+isCall c                       = not (isDecl c) && isJust (getQualIdent c)
 
 isDecl :: Code -> Bool
-isDecl (ConstructorName ConstrDecla _) = True
-isDecl (Function FunDecl            _) = True
-isDecl (TypeConstructor TypeDecla   _) = True
-isDecl _                               = False
+isDecl (DataCons ConsDeclare _) = True
+isDecl (Function FuncDeclare _) = True
+isDecl (TypeCons TypeDeclare _) = True
+isDecl _                        = False
 
 -- Translates arbitrary strings into equivalent urlencoded string.
 string2urlencoded :: String -> String
 string2urlencoded = id
-{-
-string2urlencoded [] = []
-string2urlencoded (c:cs)
-  | isAlphaNum c = c : string2urlencoded cs
-  | c == ' '     = '+' : string2urlencoded cs
-  | otherwise = show (ord c) ++ (if null cs then "" else ".") ++ string2urlencoded cs
--}
 
 htmlQuote :: String -> String
 htmlQuote [] = []

src/Html/currydoc.css

@@ -7,28 +7,28 @@ body { background: white; color: black }
 /* Show hyperlinks without underscore */
 a:visited, a:link, a:active { text-decoration: none }
 
-.keyword { color:blue }
-.constructorname_constrpattern { color : #FF00FF }
-.constructorname_constrcall { color : #FF00FF }
-.constructorname_constrdecla { color : #FF00FF }
-.constructorname_otherconstrkind { color : #FF00FF }
-.typeconstructor_typedecla  { color : #ff7f50 }
-.typeconstructor_typeuse  { color : #ff7f50 }
-.typeconstructor_typeexport  { color : #ff7f50 }
-.function_infixfunction  { color : #800080 }
-.function_typsig  { color : #800080 }
-.function_fundecl  { color : #800080 }
-.function_functioncall  { color : #800080 }
-.function_otherfunctionkind  { color : #800080 }
-.moduleName  { color : #800000 }
-.commentary  { color : green }
-.numberCode  { color : #008080 }
-.stringCode  { color : #800000 }
-.charCode  { color : #800000 }
+.linenumbers {
+  width        : 40px;
+  text-align   : right;
+  color        : grey;
+  padding-right: 10px;
+  border-right : 1px solid grey;
+}
+
+.sourcecode  {
+  padding-left: 10px;
+}
+
+.pragma  { color : green   }
+.comment { color : green   }
+.keyword { color : blue    }
 .symbol  { color : #C0C0C0 }
-.identifier_iddecl   { color : black }
-.identifier_idoccur   { color : black }
-.identifier_unknownid   { color : black }
-.codeWarning  {font-weight: bold;font-style:italic; color : red }
-.codeError  { font-style:italic; color : #a52a2a }
-.notParsed  { font-style:italic; color : #C0C0C0 }
\ No newline at end of file
+.type    { color : #ff7f50 }
+.cons    { color : #ff00ff }
+.label   { color : #90EE90 }
+.func    { color : #800080 }
+.ident   { color : black   }
+.module  { color : #800000 }
+.number  { color : #008080 }
+.string  { color : #800000 }
+.char    { color : #800000 }