Commit b43e7387 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Improved HTML generation

parent e5ac807a
......@@ -13,12 +13,13 @@
-}
module Html.CurryHtml (source2html) where
import Data.Maybe (fromMaybe, isJust)
import Data.Char (toLower)
import Data.Maybe (fromMaybe, isJust)
import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Message (fromIO)
import Curry.Files.PathUtils
(readModule, writeModule, lookupCurryFile, dropExtension, takeFileName)
(readModule, lookupCurryFile, dropExtension, takeFileName)
import Curry.Syntax (lexSource)
import Html.SyntaxColoring
......@@ -28,39 +29,32 @@ import CompilerOpts (Options(..), TargetType (..))
import Frontend (parse, fullParse)
--- translate source file into HTML file with syntaxcoloring
--- @param outputfilename
--- @param sourcefilename
source2html :: Options -> String -> IO ()
source2html opts sourcefilename = do
let imports = optImportPaths opts
outputfilename = fromMaybe "" $ optOutput opts
sourceprogname = dropExtension sourcefilename
output' = if null outputfilename
then sourceprogname ++ "_curry.html"
else outputfilename
modulname = takeFileName sourceprogname
fullfname <- lookupCurryFile imports sourcefilename
program <- filename2program opts (fromMaybe sourcefilename fullfname)
(if null outputfilename then writeModule True output'
else writeFile output')
(program2html modulname program)
source2html :: Options -> FilePath -> IO ()
source2html opts f = do
let baseName = dropExtension f
modulname = takeFileName baseName
outFileOpt = fromMaybe "" $ optOutput opts
outFile = if null outFileOpt then baseName ++ "_curry.html"
else outFileOpt
srcFile <- lookupCurryFile (optImportPaths opts) f
program <- filename2program opts (fromMaybe f srcFile)
writeFile outFile (program2html modulname program)
--- @param importpaths
--- @param filename
--- @return program
filename2program :: Options -> String -> IO Program
filename2program opts filename = do
mbModule <- readModule filename
filename2program opts f = do
mbModule <- readModule f
case mbModule of
Nothing -> abortWith ["Missing file: " ++ filename]
Just cont -> do
typingParseRes <- fromIO $ fullParse opts filename cont
fullParseRes <- fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) filename cont
let parseRes = parse filename cont
lexRes = lexSource filename cont
return $ genProgram cont [typingParseRes, fullParseRes, parseRes] lexRes
Nothing -> abortWith ["Missing file: " ++ f]
Just src -> do
typed <- fromIO $ fullParse opts f src
checked <- fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) f src
let parsed = parse f src
lexed = lexSource f src
return $ genProgram src [typed, checked, parsed] lexed
-- generates htmlcode with syntax highlighting
-- @param modulname
......@@ -77,37 +71,6 @@ program2html modulname codes =
concatMap (code2html True . (\ (_, _, c) -> c)) codes ++
"<pre>\n</body>\n</html>"
-- which code has which color
-- @param code
-- @return color of the code
code2class :: Code -> String
code2class (Keyword _) = "keyword"
code2class (Space _) = ""
code2class NewLine = ""
code2class (ConstructorName ConstrPattern _) = "constructorname_constrpattern"
code2class (ConstructorName ConstrCall _) = "constructorname_constrcall"
code2class (ConstructorName ConstrDecla _) = "constructorname_constrdecla"
code2class (ConstructorName OtherConstrKind _) = "constructorname_otherconstrkind"
code2class (Function InfixFunction _) = "function_infixfunction"
code2class (Function TypSig _) = "function_typsig"
code2class (Function FunDecl _) = "function_fundecl"
code2class (Function FunctionCall _) = "function_functioncall"
code2class (Function OtherFunctionKind _) = "function_otherfunctionkind"
code2class (ModuleName _) = "modulename"
code2class (Commentary _) = "commentary"
code2class (NumberCode _) = "numbercode"
code2class (StringCode _) = "stringcode"
code2class (CharCode _) = "charcode"
code2class (Symbol _) = "symbol"
code2class (Identifier IdDecl _) = "identifier_iddecl"
code2class (Identifier IdOccur _) = "identifier_idoccur"
code2class (Identifier UnknownId _) = "identifier_unknownid"
code2class (TypeConstructor TypeDecla _) = "typeconstructor_typedecla"
code2class (TypeConstructor TypeUse _) = "typeconstructor_typeuse"
code2class (TypeConstructor TypeExport _) = "typeconstructor_typeexport"
code2class (CodeWarning _ _) = "codewarning"
code2class (NotParsed _) = "notparsed"
code2html :: Bool -> Code -> String
code2html ownClass code@(CodeWarning _ c) =
(if ownClass then spanTag (code2class code) else id) (code2html False c)
......@@ -115,9 +78,9 @@ 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)
| isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c)
| isDecl c && ownClass = maybe tag (addHtmlAnchor tag) (getQualIdent c)
| otherwise = tag
| otherwise = tag
where tag = (if ownClass then spanTag (code2class c) else id)
(htmlQuote (code2string c))
......@@ -125,13 +88,35 @@ spanTag :: String -> String -> String
spanTag [] str = str
spanTag cl str = "<span class=\"" ++ cl ++ "\">" ++ str ++ "</span>"
-- which code has which color
-- @param code
-- @return color 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
replace :: Char -> String -> String -> String
replace old new = foldr (\ x -> if x == old then (new ++) else ([x] ++)) ""
addHtmlAnchor :: String -> QualIdent -> String
addHtmlAnchor str qualIdent = "<a name=\"" ++
string2urlencoded (show (unqualify qualIdent)) ++
"\"></a>" ++ str
addHtmlAnchor str qid = "<a name=\"" ++ anchor ++ "\"></a>" ++ str
where anchor = string2urlencoded (show (unqualify qid))
addHtmlLink :: String -> QualIdent -> String
addHtmlLink str qid =
......@@ -146,15 +131,15 @@ addHtmlLink str qid =
isCall :: Code -> Bool
isCall (TypeConstructor TypeExport _) = True
isCall (TypeConstructor _ _) = False
isCall (Identifier _ _) = False
isCall (TypeConstructor _ _) = False
isCall (Identifier _ _) = False
isCall code = not (isDecl code) && isJust (getQualIdent code)
isDecl :: Code -> Bool
isDecl (ConstructorName ConstrDecla _) = True
isDecl (Function FunDecl _) = True
isDecl (TypeConstructor TypeDecla _) = True
isDecl _ = False
isDecl (Function FunDecl _) = True
isDecl (TypeConstructor TypeDecla _) = True
isDecl _ = False
-- Translates arbitrary strings into equivalent urlencoded string.
string2urlencoded :: String -> String
......
module Html.SyntaxColoring
( Program, Code (..), TypeKind (..), ConstructorKind (..)
, IdentifierKind (..), FunctionKind (..)
, genProgram, code2string, getQualIdent, position2code, area2codes
, genProgram, code2string, getQualIdent
) where
import Data.Char hiding (Space)
......@@ -13,7 +13,7 @@ import Debug.Trace (trace)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Message
import Curry.Syntax hiding (infixOp)
import Curry.Syntax
import Base.Messages
......@@ -52,72 +52,52 @@ data Code
data TypeKind
= TypeDecla
| TypeUse
| TypeExport deriving Show
| TypeExport
deriving Show
data ConstructorKind
= ConstrPattern
| ConstrCall
| ConstrDecla
| OtherConstrKind deriving Show
| OtherConstrKind
deriving Show
data IdentifierKind
= IdDecl
| IdOccur
| UnknownId deriving Show
| UnknownId
deriving Show
data FunctionKind
= InfixFunction
| TypSig
| FunDecl
| FunctionCall
| OtherFunctionKind deriving Show
| OtherFunctionKind
deriving Show
--- @param plaintext
--- @param src
--- @param list with parse-Results with descending quality,
--- e.g. [typingParse, fullParse, parse]
--- @param lex-Result
--- @return program
genProgram :: String -> [MessageM Module] -> MessageM [(Position, Token)] -> Program
genProgram plainText parseResults m = case runMsg m of
Left e -> buildMessagesIntoPlainText [e] plainText
genProgram src parseResults lexed = case runMsg lexed of
Left e -> buildMessagesIntoPlainText [e] src
Right (posNtokList, mess) ->
let messages = (prepareMessages (concatMap getMessages parseResults ++ mess))
mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) posNtokList)
(nameList,codes) = catIdentifiers parseResults
in tokenNcodes2codes nameList 1 1 mergedMessages codes
--- @param Program
--- @param line
--- @param col
--- @return Code at this Position
position2code :: Program -> Int -> Int -> Maybe Code
position2code [] _ _ = Nothing
position2code [_] _ _ = Nothing
position2code ((l,c,code):xs@((_,c2,_):_)) lin col
| lin == l && col >= c && col < c2 = Just code
| l > lin = Nothing
| otherwise = position2code xs lin col
area2codes :: Program -> Position -> Position -> [Code]
area2codes [] _ _ = []
area2codes xxs@((l,c,code):xs) p1@Position{file=f} p2
| p1 > p2 = area2codes xxs p2 p1
| posEnd >= p1 && posBegin <= p2 = code : area2codes xs p1 p2
| posBegin > p2 = []
| otherwise = area2codes xs p1 p2
where
posBegin = Position f l c noRef
posEnd = Position f l (c + length (code2string code)) noRef
area2codes _ _ _ = internalError "SyntaxColoring.area2codes: no pattern match"
--- @param code
--- @return qualIdent if available
--- @return qid if available
getQualIdent :: Code -> Maybe QualIdent
getQualIdent (ConstructorName _ qualIdent) = Just qualIdent
getQualIdent (Function _ qualIdent) = Just qualIdent
getQualIdent (Identifier _ qualIdent) = Just qualIdent
getQualIdent (TypeConstructor _ qualIdent) = Just qualIdent
getQualIdent _ = Nothing
getQualIdent (ConstructorName _ qid) = Just qid
getQualIdent (Function _ qid) = Just qid
getQualIdent (Identifier _ qid) = Just qid
getQualIdent (TypeConstructor _ qid) = Just qid
getQualIdent _ = Nothing
-- DEBUGGING----------- wird bald nicht mehr gebraucht
......@@ -147,7 +127,7 @@ readInt s =
flatCode :: Code -> Code
flatCode (CodeWarning _ code) = code
flatCode code = code
flatCode code = code
-- ----------Message---------------------------------------
......@@ -169,31 +149,30 @@ prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
buildMessagesIntoPlainText :: [Message] -> String -> Program
buildMessagesIntoPlainText messages text =
buildMessagesIntoPlainText' messages (lines text) [] 1
buildMessagesIntoPlainText messages src =
buildMessagesIntoPlainText' messages (lines src) [] 1
where
buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' _ [] [] _ =
[]
buildMessagesIntoPlainText' _ [] postStrs ln =
[(ln,1,NotParsed (unlines postStrs))]
buildMessagesIntoPlainText' [] preStrs postStrs ln =
[(ln,1,NotParsed (unlines (preStrs ++ postStrs)))]
buildMessagesIntoPlainText' messages1 (str:preStrs) postStrs ln =
let (pre,post) = partition isLeq messages1 in
if null pre
then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)
else (ln,1,NotParsed (unlines postStrs)) :
(ln,1,CodeWarning pre (NotParsed str)) :
(ln,1,NewLine) :
buildMessagesIntoPlainText' post preStrs [] (ln + 1)
where
isLeq (Message (Just p) _) = line p <= ln
isLeq _ = True
buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' _ [] [] _ = []
buildMessagesIntoPlainText' _ [] postStrs ln =
[(ln, 1, NotParsed (unlines postStrs))]
buildMessagesIntoPlainText' [] preStrs postStrs ln =
[(ln, 1, NotParsed (unlines (preStrs ++ postStrs)))]
buildMessagesIntoPlainText' messages1 (str:preStrs) postStrs ln =
let (pre,post) = partition isLeq messages1 in
if null pre
then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)
else (ln,1,NotParsed (unlines postStrs)) :
(ln,1,CodeWarning pre (NotParsed str)) :
(ln,1,NewLine) :
buildMessagesIntoPlainText' post preStrs [] (ln + 1)
where
isLeq (Message (Just p) _) = line p <= ln
isLeq _ = True
--- @param parse-Modules [typingParse,fullParse,parse]
catIdentifiers :: [MessageM Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers :: [MessageM Module] -> ([(ModuleIdent, ModuleIdent)],[Code])
catIdentifiers = catIds . map fst . rights_sc . map runMsg
where
catIds [] = ([],[])
......@@ -204,80 +183,71 @@ catIdentifiers = catIds . map fst . rights_sc . map runMsg
-- not in base befoer base4
rights_sc :: [Either a b] -> [b]
rights_sc xs = [ x | Right x <- xs]
rights_sc es = [ x | Right x <- es]
--- @param parse-Module
--- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers' (Module moduleIdent maybeExportSpec imports decls)
catIdentifiers' (Module mid maybeExportSpec is decls)
Nothing =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
let impCodes = concatMap importDecl2codes (qsort lessImportDecl is)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
ModuleName moduleIdent :
in (concatMap renamedImports is,
ModuleName mid :
maybe [] exportSpec2codes maybeExportSpec ++ impCodes ++ codes)
catIdentifiers' (Module moduleIdent maybeExportSpec1 _ _)
(Just (Module _ maybeExportSpec2 imports decls)) =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl imports)
catIdentifiers' (Module mid maybeExportSpec1 _ _)
(Just (Module _ maybeExportSpec2 is decls)) =
let impCodes = concatMap importDecl2codes (qsort lessImportDecl is)
codes = (concatMap decl2codes (qsort lessDecl decls))
in (concatMap renamedImports imports,
in (concatMap renamedImports is,
replaceFunctionCalls $
map (addModuleIdent moduleIdent)
([ModuleName moduleIdent] ++
map (addModuleIdent mid)
([ModuleName mid] ++
mergeExports2codes
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec1)
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec2) ++
impCodes ++ codes))
renamedImports :: ImportDecl -> [(ModuleIdent,ModuleIdent)]
renamedImports :: ImportDecl -> [(ModuleIdent, ModuleIdent)]
renamedImports (ImportDecl _ oldName _ (Just newName) _) = [(oldName,newName)]
renamedImports _ = []
renamedImports _ = []
replaceFunctionCalls :: [Code] -> [Code]
replaceFunctionCalls codes = map (idOccur2functionCall qualIdents) codes
where
qualIdents = findFunctionDecls codes
replaceFunctionCalls codes = map (idOccur2functionCall qids) codes
where qids = findFunctionDecls codes
findFunctionDecls :: [Code] -> [QualIdent]
findFunctionDecls = mapMaybe getQualIdent .
filter isFunctionDecl .
map flatCode
findFunctionDecls = mapMaybe getQualIdent . filter isFunctionDecl . map flatCode
isFunctionDecl :: Code -> Bool
isFunctionDecl (Function FunDecl _) = True
isFunctionDecl _ = False
isFunctionDecl :: Code -> Bool
isFunctionDecl (Function FunDecl _) = True
isFunctionDecl _ = False
idOccur2functionCall :: [QualIdent] -> Code -> Code
idOccur2functionCall qualIdents ide@(Identifier IdOccur qualIdent)
| isQualified qualIdent = Function FunctionCall qualIdent
| elem qualIdent qualIdents = Function FunctionCall qualIdent
| otherwise = ide
idOccur2functionCall qualIdents (CodeWarning mess code) =
CodeWarning mess (idOccur2functionCall qualIdents code)
idOccur2functionCall qids ide@(Identifier IdOccur qid)
| isQualified qid = Function FunctionCall qid
| elem qid qids = Function FunctionCall qid
| otherwise = ide
idOccur2functionCall qids (CodeWarning mess code) =
CodeWarning mess (idOccur2functionCall qids code)
idOccur2functionCall _ code = code
addModuleIdent :: ModuleIdent -> Code -> Code
addModuleIdent moduleIdent c@(Function x qualIdent)
| idUnique (unqualify qualIdent) == 0 =
Function x (qualQualify moduleIdent qualIdent)
| otherwise = c
addModuleIdent moduleIdent cn@(ConstructorName x qualIdent)
| not $ isQualified qualIdent =
ConstructorName x (qualQualify moduleIdent qualIdent)
| otherwise = cn
addModuleIdent moduleIdent tc@(TypeConstructor TypeDecla qualIdent)
| not $ isQualified qualIdent =
TypeConstructor TypeDecla (qualQualify moduleIdent qualIdent)
| otherwise = tc
addModuleIdent moduleIdent (CodeWarning mess code) =
CodeWarning mess (addModuleIdent moduleIdent code)
addModuleIdent mid c@(Function x qid)
| hasGlobalScope (unqualify qid) = Function x (qualQualify mid qid)
| otherwise = c
addModuleIdent mid cn@(ConstructorName x qid)
| not $ isQualified qid = ConstructorName x (qualQualify mid qid)
| otherwise = cn
addModuleIdent mid tc@(TypeConstructor TypeDecla qid)
| not $ isQualified qid = TypeConstructor TypeDecla (qualQualify mid qid)
| otherwise = tc
addModuleIdent mid (CodeWarning mess code) =
CodeWarning mess (addModuleIdent mid code)
addModuleIdent _ c = c
-- ----------------------------------------
mergeMessages' :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
mergeMessages' _ [] = []
mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps
......@@ -285,54 +255,53 @@ mergeMessages' mss@(m@(Message mPos x):ms) ((p,t):ps)
| mPos <= Just p = trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ show x) ([m],p,t) : mergeMessages' ms ps
| otherwise = ([],p,t) : mergeMessages' mss ps
tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([Message],Position,Token)] -> [Code] -> [(Int,Int,Code)]
tokenNcodes2codes _ _ _ [] _ = []
tokenNcodes2codes nameList currLine currCol toks@((messages,Position{line=row,column=col},token):ts) codes
| currLine < row =
trace' " NewLine: "
((currLine,currCol,NewLine) :
tokenNcodes2codes nameList (currLine + 1) 1 toks codes)
| currCol < col =
trace' (" Space " ++ show (col - currCol))
((currLine,currCol,Space (col - currCol)) :
tokenNcodes2codes nameList currLine col toks codes)
| isTokenIdentifier token && null codes =
trace' ("empty Code-List, Token: " ++ show (row,col) ++ show token)
(addMessage [(currLine,currCol,NotParsed tokenStr)] ++ tokenNcodes2codes nameList newLine newCol ts codes)
| not (isTokenIdentifier token) =
trace' (" Token ist kein Identifier: " ++ tokenStr )
(addMessage [(currLine,currCol,token2code token)] ++ tokenNcodes2codes nameList newLine newCol ts codes)
| tokenStr == code2string (head codes) =
trace' (" Code wird genommen: " ++ show (head codes) )
(addMessage [(currLine,currCol,head codes)] ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))
| tokenStr == code2qualString (renameModuleIdents nameList (head codes)) =
let mIdent = maybe Nothing rename (getModuleIdent (head codes))
lenMod = maybe 0 (length . moduleName) mIdent
startPos = maybe currCol (const (currCol + lenMod + 1)) mIdent
symbol = [(currLine,currCol + lenMod,Symbol ".")]
prefix = maybe []
( (: symbol) .
( \i -> (currLine,
currCol,
ModuleName i)))
mIdent in
trace' (" Code wird genommen: " ++ show (head codes) )
(addMessage (prefix ++ [(currCol,startPos,head codes)]) ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))
| elem tokenStr (codeQualifiers (head codes)) =
trace' (" Token: "++ tokenStr ++" ist Modulname von: " ++ show (head codes) )
(addMessage [(currLine,currCol,ModuleName (mkMIdent [tokenStr]))] ++
tokenNcodes2codes nameList newLine newCol ts codes)
| otherwise =
trace' (" Token: "++
tokenStr ++
",Code faellt weg:" ++
code2string (head codes) ++
"|" ++
code2qualString (head codes))
(tokenNcodes2codes nameList currLine currCol toks (tail codes))
| currLine < row =
trace' " NewLine: "
((currLine,currCol,NewLine) :
tokenNcodes2codes nameList (currLine + 1) 1 toks codes)
| currCol < col =
trace' (" Space " ++ show (col - currCol))
((currLine,currCol,Space (col - currCol)) :
tokenNcodes2codes nameList currLine col toks codes)
| isTokenIdentifier token && null codes =
trace' ("empty Code-List, Token: " ++ show (row,col) ++ show token)
(addMessage [(currLine,currCol,NotParsed tokenStr)] ++ tokenNcodes2codes nameList newLine newCol ts codes)
| not (isTokenIdentifier token) =
trace' (" Token ist kein Identifier: " ++ tokenStr )
(addMessage [(currLine,currCol,token2code token)] ++ tokenNcodes2codes nameList newLine newCol ts codes)
| tokenStr == code2string (head codes) =
trace' (" Code wird genommen: " ++ show (head codes) )
(addMessage [(currLine,currCol,head codes)] ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))
| tokenStr == code2qualString (renameModuleIdents nameList (head codes)) =
let mIdent = maybe Nothing rename (getModuleIdent (head codes))
lenMod = maybe 0 (length . moduleName) mIdent
startPos = maybe currCol (const (currCol + lenMod + 1)) mIdent
symbol = [(currLine,currCol + lenMod,Symbol ".")]
prefix = maybe []
( (: symbol) .
( \i -> (currLine,
currCol,
ModuleName i)))
mIdent in
trace' (" Code wird genommen: " ++ show (head codes) )
(addMessage (prefix ++ [(currCol,startPos,head codes)]) ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))
| elem tokenStr (codeQualifiers (head codes)) =
trace' (" Token: "++ tokenStr ++" ist Modulname von: " ++ show (head codes) )
(addMessage [(currLine,currCol,ModuleName (mkMIdent [tokenStr]))] ++
tokenNcodes2codes nameList newLine newCol ts codes)
| otherwise =
trace' (" Token: "++
tokenStr ++
",Code faellt weg:" ++
code2string (head codes) ++
"|" ++
code2qualString (head codes))
(tokenNcodes2codes nameList currLine currCol toks (tail codes))
where
tokenStr = token2string token
tokenStr = showToken token
newLine = (currLine + length (lines tokenStr)) - 1
newCol = currCol + length tokenStr
......@@ -349,99 +318,73 @@ tokenNcodes2codes _ _ _ _ _ = internalError "SyntaxColoring.tokenNcodes2codes: n
renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code
renameModuleIdents nameList c =
case c of
Function x qualIdent -> Function x (rename qualIdent (qidModule qualIdent))
Identifier x qualIdent -> Identifier x (rename qualIdent (qidModule qualIdent))
Function x qid -> Function x (rename qid (qidModule qid))
Identifier x qid -> Identifier x (rename qid (qidModule qid))
_ -> c
where
rename x (Nothing) = x
rename x (Just m) = maybe x (\ m' -> qualifyWith m' (qidIdent x)) (lookup m nameList)
{-
codeWithoutUniqueID :: Code -> String
codeWithoutUniqueID code = maybe (code2string code) (name . unqualify) $ getQualIdent code
codeUnqualify :: Code -> Code
codeUnqualify code = maybe code (setQualIdent code . qualify . unqualify) $ getQualIdent code
-}
codeQualifiers :: Code -> [String]
codeQualifiers = maybe [] midQualifiers . getModuleIdent
getModuleIdent :: Code -> Maybe ModuleIdent
getModuleIdent (ConstructorName _ qualIdent) = qidModule qualIdent
getModuleIdent (Function _ qualIdent) = qidModule qualIdent
getModuleIdent (ModuleName moduleIdent) = Just moduleIdent
getModuleIdent (Identifier _ qualIdent) = qidModule qualIdent