Fixed linking for identifiers in Curry HTML documentation

src/Html/CurryHtml.hs

 {- |
     Module      :  $Header$
     Description :  Generating HTML documentation
-    Copyright   :  (c) 2011 - 2015, Björn Peemöller
+    Copyright   :  (c) 2011 - 2016, Björn Peemöller
+                       2016       , Jan Tikovsky
     License     :  OtherLicense
 
     Maintainer  :  bjp@informatik.uni-kiel.de
@@ -73,7 +74,7 @@ docModule opts f = do
     Just src -> do
       toks  <- liftCYM $ lexSource f src
       typed@(Module _ m _ _ _) <- fullParse opts f src
-      return (m, program2html m $ genProgram f typed toks)
+      return (m, program2html m $ genProgram typed toks)
 
 -- |Return the syntax tree of the source program 'src' (type 'Module'; see
 -- Module "CurrySyntax").after inferring the types of identifiers.
@@ -147,20 +148,20 @@ spanTag clV idV str
 -- @param code
 -- @return css class of the code
 code2class :: Code -> String
-code2class (Space        _) = ""
-code2class NewLine          = ""
-code2class (Keyword      _) = "keyword"
-code2class (Pragma       _) = "pragma"
-code2class (Symbol       _) = "symbol"
-code2class (TypeCons   _ _) = "type"
-code2class (DataCons   _ _) = "cons"
-code2class (Function   _ _) = "func"
-code2class (Identifier _ _) = "ident"
-code2class (ModuleName   _) = "module"
-code2class (Commentary   _) = "comment"
-code2class (NumberCode   _) = "number"
-code2class (StringCode   _) = "string"
-code2class (CharCode     _) = "char"
+code2class (Space          _) = ""
+code2class NewLine            = ""
+code2class (Keyword        _) = "keyword"
+code2class (Pragma         _) = "pragma"
+code2class (Symbol         _) = "symbol"
+code2class (TypeCons   _ _ _) = "type"
+code2class (DataCons   _ _ _) = "cons"
+code2class (Function   _ _ _) = "func"
+code2class (Identifier _ _ _) = "ident"
+code2class (ModuleName     _) = "module"
+code2class (Commentary     _) = "comment"
+code2class (NumberCode     _) = "number"
+code2class (StringCode     _) = "string"
+code2class (CharCode       _) = "char"
 
 addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
 addModuleLink m m' str 
@@ -182,18 +183,18 @@ htmlFile :: ModuleIdent -> String
 htmlFile m = moduleName m ++ "_curry.html"
 
 isCall :: Code -> Bool
-isCall (TypeCons TypeExport _) = True
-isCall (TypeCons TypeImport _) = True
-isCall (TypeCons TypeRefer  _) = True
-isCall (TypeCons          _ _) = False
-isCall (Identifier        _ _) = False
+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 (DataCons ConsDeclare  _) = True
-isDecl (Function FuncDeclare  _) = True
-isDecl (TypeCons TypeDeclare  _) = 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

src/Html/SyntaxColoring.hs

 {- |
     Module      :  $Header$
     Description :  Split module into code fragments
-    Copyright   :  (c)  ??  , someone else
-                        2014, Björn Peemöller
+    Copyright   :  (c)  ??         , someone else
+                        2014 - 2016, Björn Peemöller
+                        2016       , Jan Tikovsky
     License     :  OtherLicense
 
     Maintainer  :  bjp@informatik.uni-kiel.de
@@ -10,8 +11,22 @@
     Portability :  portable
 
     This module arranges the tokens of the module into different code
-    categories for HTML presentation. The parsed and typechecked module
+    categories for HTML presentation. The parsed and qualified module
     is used to establish links between used identifiers and their definitions.
+
+    The fully qualified module is traversed to generate a list of code elements.
+    Code elements representing identifiers are distinguished by their kind
+    (type constructor, data constructor, function, (type) variable).
+    They include information about their usage (i.e., declaration, call etc.)
+    and whether the identifier occurs fully qualified in
+    the source code or not. Initially, all identifier codes are fully qualified.
+
+    In a next step, the token stream of the given program and the code list are
+    traversed sequentially (see `encodeToks`). The information in the token
+    stream is used to:
+
+      * add code elements for newlines, spaces and pragmas
+      * update the qualification information of identifiers in the code list.
 -}
 
 module Html.SyntaxColoring
@@ -30,15 +45,17 @@ import Curry.Syntax
 import Base.Messages
 
 -- |Type of codes which are distinguished for HTML output
+-- the boolean flags indicate whether the corresponding identifier
+-- occurs qualified in the source module
 data Code
   = Keyword     String
   | Space       Int
   | NewLine
   | Pragma      String
-  | TypeCons    TypeUsage  QualIdent
-  | DataCons    ConsUsage  QualIdent
-  | Function    FuncUsage  QualIdent
-  | Identifier  IdentUsage QualIdent
+  | TypeCons    TypeUsage  Bool QualIdent
+  | DataCons    ConsUsage  Bool QualIdent
+  | Function    FuncUsage  Bool QualIdent
+  | Identifier  IdentUsage Bool QualIdent
   | ModuleName  ModuleIdent
   | Commentary  String
   | NumberCode  String
@@ -78,21 +95,28 @@ data IdentUsage
   | IdUnknown -- unknown usage
     deriving Show
 
--- @param list with parse-Results with descending quality,
---        e.g. [typingParse, fullParse, parse]
+-- @param fully qualified module
 -- @param lex-Result
--- @return program
-genProgram :: String -> Module -> [(Position, Token)] -> [Code]
-genProgram fn m toks = encodeToks (first fn) (idsModule m) toks
+-- @return code list
+genProgram :: Module -> [(Position, Token)] -> [Code]
+genProgram m pts = encodeToks (first "") (filter validCode (idsModule m)) pts
+
+-- predicate to remove identifier codes for primitives
+-- because they do not form valid link targets
+validCode :: Code -> Bool
+validCode (TypeCons   _ _ t) = t `notElem` [qUnitId, qListId]         && not (isQTupleId t)
+validCode (DataCons   _ _ c) = c `notElem` [qUnitId, qNilId, qConsId] && not (isQTupleId c)
+validCode (Identifier _ _ i) = not $ isAnonId $ unqualify i
+validCode _                  = True
 
 -- @param code
 -- @return qid if available
 getQualIdent :: Code -> Maybe QualIdent
-getQualIdent (DataCons    _ qid) = Just qid
-getQualIdent (Function    _ qid) = Just qid
-getQualIdent (Identifier  _ qid) = Just qid
-getQualIdent (TypeCons    _ qid) = Just qid
-getQualIdent  _                  = Nothing
+getQualIdent (DataCons   _ _ qid) = Just qid
+getQualIdent (Function   _ _ qid) = Just qid
+getQualIdent (Identifier _ _ qid) = Just qid
+getQualIdent (TypeCons   _ _ qid) = Just qid
+getQualIdent _                    = Nothing
 
 encodeToks :: Position -> [Code] -> [(Position, Token)] -> [Code]
 encodeToks _   _   []                     = []
@@ -108,30 +132,47 @@ encodeToks cur ids toks@((pos, tok) : ts)
                               in  Pragma s : encodeToks (incr cur (length s)) ids rest
   -- identifier token
   | isIdentTok tok          = case ids of
-    []                                 -> encodeTok tok : encodeToks newPos [] ts
-    (i:is) | tokenStr == code2string i -> i : encodeToks newPos is ts
-           | otherwise                 -> encodeToks cur is toks
+    []     -> encodeTok tok : encodeToks newPos [] ts
+    (i:is)
+      | tokenStr == code2string i' -> i' : encodeToks newPos is ts
+  -- the 'otherwise' case should never occur if the token stream and
+  -- the qualified AST which was used to generate the code list correspond to
+  -- the same module
+      | otherwise                  -> encodeToks cur is toks
+      where i' = setQualified (isQualIdentTok tok) i
   -- other token
   | otherwise               = encodeTok tok : encodeToks newPos ids ts
   where
   tokenStr = showToken tok
   newPos   = incr cur (length tokenStr)
 
+setQualified :: Bool -> Code -> Code
+setQualified b (DataCons   u _ c) = DataCons u b c
+setQualified b (Function   u _ f) = Function u b f
+setQualified b (Identifier u _ i) = Identifier u b i
+setQualified b (TypeCons   u _ t) = TypeCons u b t
+setQualified _ m@(ModuleName   _) = m
+setQualified _ c                  = internalError $ "Html.SyntaxColoring.setQualified: " ++ show c
+
 code2string :: Code -> String
-code2string (Keyword         s) = s
-code2string (Space           i) = replicate i ' '
-code2string NewLine             = "\n"
-code2string (Pragma          s) = s
-code2string (DataCons    _ qid) = qualName   qid
-code2string (TypeCons    _ qid) = qualName   qid
-code2string (Function    _ qid) = qualName   qid
-code2string (Identifier  _ qid) = qualName   qid
-code2string (ModuleName    mid) = moduleName mid
-code2string (Commentary      s) = s
-code2string (NumberCode      s) = s
-code2string (StringCode      s) = s
-code2string (CharCode        s) = s
-code2string (Symbol          s) = s
+code2string (Keyword           s) = s
+code2string (Space             i) = replicate i ' '
+code2string NewLine               = "\n"
+code2string (Pragma            s) = s
+code2string (DataCons    _ b qid) = ident2string b qid
+code2string (TypeCons    _ b qid) = ident2string b qid
+code2string (Function    _ b qid) = ident2string b qid
+code2string (Identifier  _ b qid) = ident2string b qid
+code2string (ModuleName      mid) = moduleName mid
+code2string (Commentary        s) = s
+code2string (NumberCode        s) = s
+code2string (StringCode        s) = s
+code2string (CharCode          s) = s
+code2string (Symbol            s) = s
+
+ident2string :: Bool -> QualIdent -> String
+ident2string False q = idName $ unqualify q
+ident2string True  q = qualName q
 
 encodeTok :: Token -> Code
 encodeTok tok@(Token c _)
@@ -143,7 +184,7 @@ encodeTok tok@(Token c _)
   | c `elem` punctuationCategories  = Symbol     (showToken tok)
   | c `elem` reservedOpsCategories  = Symbol     (showToken tok)
   | c `elem` commentCategories      = Commentary (showToken tok)
-  | c `elem` identCategories        = Identifier IdUnknown $ qualify $ mkIdent
+  | c `elem` identCategories        = Identifier IdUnknown False $ qualify $ mkIdent
                                       $ showToken tok
   | c `elem` whiteSpaceCategories   = Space 0
   | c `elem` pragmaCategories       = Pragma     (showToken tok)
@@ -190,6 +231,9 @@ isPragmaEnd (Token c _) = c == PragmaEnd
 isIdentTok :: Token -> Bool
 isIdentTok (Token c _) = c `elem` identCategories
 
+isQualIdentTok :: Token -> Bool
+isQualIdentTok (Token c _) = c `elem` [QId, QSym]
+
 whiteSpaceCategories :: [Category]
 whiteSpaceCategories = [EOF, VSemicolon, VRightBrace]
 
@@ -237,10 +281,10 @@ idsExportSpec Nothing                 = []
 idsExportSpec (Just (Exporting _ es)) = concatMap idsExport es
 
 idsExport :: Export -> [Code]
-idsExport (Export            qid) = [Function FuncExport qid]
-idsExport (ExportTypeWith qid cs) = TypeCons TypeExport qid :
-  map (DataCons ConsExport . qualify) cs
-idsExport (ExportTypeAll     qid) = [TypeCons TypeExport qid]
+idsExport (Export            qid) = [Function FuncExport False qid]
+idsExport (ExportTypeWith qid cs) = TypeCons TypeExport False qid :
+  map (DataCons ConsExport False . qualify) cs
+idsExport (ExportTypeAll     qid) = [TypeCons TypeExport False qid]
 idsExport (ExportModule      mid) = [ModuleName mid]
 
 -- Imports
@@ -256,53 +300,53 @@ idsImportSpec mid (Hiding    _ is) = concatMap (idsImport mid) is
 
 idsImport :: ModuleIdent -> Import -> [Code]
 idsImport mid (Import            i) =
-  [Function FuncImport $ qualifyWith mid i]
+  [Function FuncImport False $ qualifyWith mid i]
 idsImport mid (ImportTypeWith t cs) =
-  TypeCons TypeImport (qualifyWith mid t) :
-    map (DataCons ConsImport . qualifyWith mid) cs
+  TypeCons TypeImport False (qualifyWith mid t) :
+    map (DataCons ConsImport False . qualifyWith mid) cs
 idsImport mid (ImportTypeAll     t) =
-  [TypeCons TypeImport $ qualifyWith mid t]
+  [TypeCons TypeImport False $ qualifyWith mid t]
 
 -- Declarations
 
 idsDecl :: Decl -> [Code]
-idsDecl (InfixDecl _   _ _ ops) = map (Function FuncInfix . qualify) ops
-idsDecl (DataDecl   _ d vs cds) = TypeCons TypeDeclare (qualify d)
-                                    :  map (Identifier IdDeclare . qualify) vs
+idsDecl (InfixDecl _   _ _ ops) = map (Function FuncInfix False . qualify) ops
+idsDecl (DataDecl   _ d vs cds) = TypeCons TypeDeclare False (qualify d)
+                                    :  map (Identifier IdDeclare False . qualify) vs
                                     ++ concatMap idsConstrDecl cds
-idsDecl (NewtypeDecl _ t vs nc) = TypeCons TypeDeclare (qualify t)
-                                    :  map (Identifier IdDeclare . qualify) vs
+idsDecl (NewtypeDecl _ t vs nc) = TypeCons TypeDeclare False (qualify t)
+                                    :  map (Identifier IdDeclare False . qualify) vs
                                     ++ idsNewConstrDecl nc
-idsDecl (TypeDecl    _ t vs ty) = TypeCons TypeDeclare (qualify t)
-                                    :  map (Identifier IdDeclare . qualify) vs
+idsDecl (TypeDecl    _ t vs ty) = TypeCons TypeDeclare False (qualify t)
+                                    :  map (Identifier IdDeclare False . qualify) vs
                                     ++ idsTypeExpr ty
-idsDecl (TypeSig       _ fs ty) = map (Function FuncTypeSig . qualify) fs
+idsDecl (TypeSig       _ fs ty) = map (Function FuncTypeSig False . qualify) fs
                                     ++ idsTypeExpr ty
 idsDecl (FunctionDecl  _ _ eqs) = concatMap idsEquation eqs
 idsDecl (ForeignDecl _ _ _ _ _) = []
-idsDecl (ExternalDecl     _ fs) = map (Function FuncDeclare . qualify) fs
+idsDecl (ExternalDecl     _ fs) = map (Function FuncDeclare False . qualify) fs
 idsDecl (PatternDecl   _ p rhs) = idsPat p ++ idsRhs rhs
-idsDecl (FreeDecl         _ vs) = map (Identifier IdDeclare . qualify) vs
+idsDecl (FreeDecl         _ vs) = map (Identifier IdDeclare False . qualify) vs
 
 idsConstrDecl :: ConstrDecl -> [Code]
 idsConstrDecl (ConstrDecl     _ _ c tys)
-  = DataCons ConsDeclare (qualify c) : concatMap idsTypeExpr tys
+  = DataCons ConsDeclare False (qualify c) : concatMap idsTypeExpr tys
 idsConstrDecl (ConOpDecl _ _ ty1 op ty2)
-  = idsTypeExpr ty1 ++ (DataCons ConsDeclare $ qualify op) : idsTypeExpr ty2
+  = idsTypeExpr ty1 ++ (DataCons ConsDeclare False $ qualify op) : idsTypeExpr ty2
 idsConstrDecl (RecordDecl _ _ c fs)
-  = DataCons ConsDeclare (qualify c) : concatMap idsFieldDecl fs
+  = DataCons ConsDeclare False (qualify c) : concatMap idsFieldDecl fs
 
 idsNewConstrDecl :: NewConstrDecl -> [Code]
 idsNewConstrDecl (NewConstrDecl _ _ c ty)
-  = DataCons ConsDeclare (qualify c) : idsTypeExpr ty
+  = DataCons ConsDeclare False (qualify c) : idsTypeExpr ty
 idsNewConstrDecl (NewRecordDecl _ _ c (l,ty))
-  = DataCons ConsDeclare (qualify c) : (Function FuncDeclare $ qualify l)
+  = DataCons ConsDeclare False (qualify c) : (Function FuncDeclare False $ qualify l)
   : idsTypeExpr ty
 
 idsTypeExpr :: TypeExpr -> [Code]
-idsTypeExpr (ConstructorType qid tys) = TypeCons TypeRefer qid :
+idsTypeExpr (ConstructorType qid tys) = TypeCons TypeRefer False qid :
                                            concatMap idsTypeExpr tys
-idsTypeExpr (VariableType          v) = [Identifier IdRefer (qualify v)]
+idsTypeExpr (VariableType          v) = [Identifier IdRefer False (qualify v)]
 idsTypeExpr (TupleType           tys) = concatMap idsTypeExpr tys
 idsTypeExpr (ListType             ty) = idsTypeExpr ty
 idsTypeExpr (ArrowType       ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]
@@ -310,14 +354,14 @@ idsTypeExpr (ParenType            ty) = idsTypeExpr ty
 
 idsFieldDecl :: FieldDecl -> [Code]
 idsFieldDecl (FieldDecl _ ls ty) =
-  map (Function FuncDeclare . qualify . unRenameIdent) ls ++ idsTypeExpr ty
+  map (Function FuncDeclare False . qualify . unRenameIdent) ls ++ idsTypeExpr ty
 
 idsEquation :: Equation -> [Code]
 idsEquation (Equation _ lhs rhs) = idsLhs lhs ++ idsRhs rhs
 
 idsLhs :: Lhs -> [Code]
-idsLhs (FunLhs    f ps) = Function FuncDeclare (qualify f) : concatMap idsPat ps
-idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare $ qualify op]
+idsLhs (FunLhs    f ps) = Function FuncDeclare False (qualify f) : concatMap idsPat ps
+idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare False $ qualify op]
                                     ++ idsPat p2
 idsLhs (ApLhs   lhs ps) = idsLhs lhs ++ concatMap idsPat ps
 
@@ -331,33 +375,33 @@ idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2
 idsPat :: Pattern -> [Code]
 idsPat (LiteralPattern          _) = []
 idsPat (NegativePattern       _ _) = []
-idsPat (VariablePattern         v) = [Identifier IdDeclare (qualify v)]
-idsPat (ConstructorPattern qid ps) = DataCons ConsPattern qid
+idsPat (VariablePattern         v) = [Identifier IdDeclare False (qualify v)]
+idsPat (ConstructorPattern qid ps) = DataCons ConsPattern False qid
                                       : concatMap idsPat ps
 idsPat (InfixPattern    p1 qid p2) = idsPat p1 ++
-                                       DataCons ConsPattern qid : idsPat p2
+                                       DataCons ConsPattern False qid : idsPat p2
 idsPat (ParenPattern            p) = idsPat p
-idsPat (RecordPattern      qid fs) = DataCons ConsPattern qid
+idsPat (RecordPattern      qid fs) = DataCons ConsPattern False qid
                                       : concatMap (idsField idsPat) fs
 idsPat (TuplePattern         _ ps) = concatMap idsPat ps
 idsPat (ListPattern          _ ps) = concatMap idsPat ps
-idsPat (AsPattern             v p) = Identifier IdDeclare (qualify v) : idsPat p
+idsPat (AsPattern             v p) = Identifier IdDeclare False (qualify v) : idsPat p
 idsPat (LazyPattern           _ p) = idsPat p
-idsPat (FunctionPattern    qid ps) = Function FuncCall qid
+idsPat (FunctionPattern    qid ps) = Function FuncCall False qid
                                       : concatMap idsPat ps
 idsPat (InfixFuncPattern  p1 f p2) = idsPat p1 ++
-                                      Function FuncInfix f : idsPat p2
+                                      Function FuncInfix False f : idsPat p2
 
 idsExpr :: Expression -> [Code]
 idsExpr (Literal                _) = []
 idsExpr (Variable             qid)
-  | isQualified qid                = [Function FuncCall qid]
-  | hasGlobalScope (unqualify qid) = [Function FuncCall qid]
-  | otherwise                      = [Identifier IdRefer qid]
-idsExpr (Constructor          qid) = [DataCons ConsCall qid]
+  | isQualified qid                = [Function FuncCall False qid]
+  | hasGlobalScope (unqualify qid) = [Function FuncCall False qid]
+  | otherwise                      = [Identifier IdRefer False qid]
+idsExpr (Constructor          qid) = [DataCons ConsCall False qid]
 idsExpr (Paren                  e) = idsExpr e
 idsExpr (Typed               e ty) = idsExpr e ++ idsTypeExpr ty
-idsExpr (Record            qid fs) = DataCons ConsCall qid
+idsExpr (Record            qid fs) = DataCons ConsCall False qid
                                       : concatMap (idsField idsExpr) fs
 idsExpr (RecordUpdate        e fs) = idsExpr e
                                       ++ concatMap (idsField idsExpr) fs
@@ -380,11 +424,11 @@ idsExpr (IfThenElse    _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]
 idsExpr (Case          _ _ e alts) = idsExpr e ++ concatMap idsAlt alts
 
 idsField :: (a -> [Code]) -> Field a -> [Code]
-idsField f (Field _ l x) = Function FuncCall l : f x
+idsField f (Field _ l x) = Function FuncCall False l : f x
 
 idsInfix :: InfixOp -> [Code]
-idsInfix (InfixOp     qid) = [Function FuncInfix qid]
-idsInfix (InfixConstr qid) = [DataCons ConsInfix qid]
+idsInfix (InfixOp     qid) = [Function FuncInfix False qid]
+idsInfix (InfixConstr qid) = [DataCons ConsInfix False qid]
 
 idsStmt :: Statement -> [Code]
 idsStmt (StmtExpr   _ e) = idsExpr e