diff --git a/curry-frontend.cabal b/curry-frontend.cabal
index b28deea711b9ea9b29a16289686b80732715c1f6..4ca9cdf871e16d5779dda96081213e0229a5ebe4 100644
--- a/curry-frontend.cabal
+++ b/curry-frontend.cabal
@@ -1,5 +1,5 @@
Name: curry-frontend
-Version: 0.3.5
+Version: 0.3.6
Cabal-Version: >= 1.6
Synopsis: Compile the functional logic language Curry to several
intermediate formats
@@ -35,7 +35,7 @@ Executable cymake
else
Build-Depends: base == 3.*
Build-Depends:
- curry-base == 0.3.5
+ curry-base == 0.3.6
, mtl, containers, pretty, transformers
ghc-options: -Wall
Other-Modules:
diff --git a/src/Html/CurryHtml.hs b/src/Html/CurryHtml.hs
index bc7b3bc6131f8ba1ce0fcb76c41c7e143cf22419..9400647da8deffc839bedc66091dec24acd4b9f3 100644
--- a/src/Html/CurryHtml.hs
+++ b/src/Html/CurryHtml.hs
@@ -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><</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
diff --git a/src/Html/SyntaxColoring.hs b/src/Html/SyntaxColoring.hs
index bc7df9c10620347c7265cea81c85bc48887f6dfe..db39aa855e21443f49d1ee18aff77974b70e8e30 100644
--- a/src/Html/SyntaxColoring.hs
+++ b/src/Html/SyntaxColoring.hs
@@ -1,7 +1,7 @@
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
-getModuleIdent (TypeConstructor _ qualIdent) = qidModule qualIdent
-getModuleIdent _ = Nothing
-
-{-
-setQualIdent :: Code -> QualIdent -> Code
-setQualIdent (Keyword str) _ = (Keyword str)
-setQualIdent (Space i) _ = (Space i)
-setQualIdent NewLine _ = NewLine
-setQualIdent (ConstructorName kind _) qualIdent = (ConstructorName kind qualIdent)
-setQualIdent (Function kind _) qualIdent = (Function kind qualIdent)
-setQualIdent (ModuleName moduleIdent) _ = (ModuleName moduleIdent)
-setQualIdent (Commentary str) _ = (Commentary str)
-setQualIdent (NumberCode str) _ = (NumberCode str)
-setQualIdent (Symbol str) _ = (Symbol str)
-setQualIdent (Identifier kind _) qualIdent = (Identifier kind qualIdent)
-setQualIdent (TypeConstructor kind _) qualIdent = (TypeConstructor kind qualIdent)
-setQualIdent (StringCode str) _ = (StringCode str)
-setQualIdent (CharCode str) _ = (CharCode str)
--}
+getModuleIdent (ConstructorName _ qid) = qidModule qid
+getModuleIdent (Function _ qid) = qidModule qid
+getModuleIdent (ModuleName mid) = Just mid
+getModuleIdent (Identifier _ qid) = qidModule qid
+getModuleIdent (TypeConstructor _ qid) = qidModule qid
+getModuleIdent _ = Nothing
code2string :: Code -> String
-code2string (Keyword str) = str
-code2string (Space i)= concat (replicate i " ")
-code2string NewLine = "\n"
-code2string (ConstructorName _ qualIdent) = idName $ unqualify qualIdent
-code2string (TypeConstructor _ qualIdent) = idName $ unqualify qualIdent
-code2string (Function _ qualIdent) = idName $ unqualify qualIdent
-code2string (ModuleName moduleIdent) = moduleName moduleIdent
-code2string (Commentary str) = str
-code2string (NumberCode str) = str
-code2string (StringCode str) = str
-code2string (CharCode str) = str
-code2string (Symbol str) = str
-code2string (Identifier _ qualIdent) = idName $ unqualify qualIdent
-code2string (CodeWarning _ c) = code2string c
-code2string (NotParsed str) = str
+code2string (Keyword s) = s
+code2string (Space i) = concat (replicate i " ")
+code2string NewLine = "\n"
+code2string (ConstructorName _ qid) = idName $ unqualify qid
+code2string (TypeConstructor _ qid) = idName $ unqualify qid
+code2string (Function _ qid) = idName $ unqualify 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 (Identifier _ qid) = idName $ unqualify qid
+code2string (CodeWarning _ c) = code2string c
+code2string (NotParsed s) = s
code2qualString :: Code -> String
-code2qualString (ConstructorName _ qualIdent) = qualName qualIdent
-code2qualString (Function _ qualIdent) = qualName qualIdent
-code2qualString (Identifier _ qualIdent) = qualName qualIdent
-code2qualString (TypeConstructor _ qualIdent) = qualName qualIdent
+code2qualString (ConstructorName _ qid) = qualName qid
+code2qualString (Function _ qid) = qualName qid
+code2qualString (Identifier _ qid) = qualName qid
+code2qualString (TypeConstructor _ qid) = qualName qid
code2qualString x = code2string x
token2code :: Token -> Code
token2code tok@(Token cat _)
- | elem cat [IntTok,FloatTok]
- = NumberCode (token2string tok)
- | elem cat [KW_case,KW_data,KW_do,KW_else,KW_external,
- KW_free,KW_if,KW_import,KW_in,KW_infix,KW_infixl,KW_infixr,
- KW_let,KW_module,KW_newtype,KW_of,KW_then,KW_type,
- KW_where,Id_as,Id_ccall,Id_forall,Id_hiding,Id_interface,Id_primitive,
- Id_qualified]
- = Keyword (token2string tok)
- | elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,
- RightBracket,Comma,Underscore,Backquote,
- At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
- Tilde]
- = Symbol (token2string tok)
- | elem cat [LineComment, NestedComment]
- = Commentary (token2string tok)
- | isTokenIdentifier tok
- = Identifier UnknownId $ qualify $ mkIdent $ token2string tok
- | cat == StringTok
- = StringCode (token2string tok)
- | cat == CharTok
- = CharCode (token2string tok)
- | elem cat [EOF,VSemicolon,VRightBrace] = Space 0
- | otherwise = error "SyntaxColoring.token2code: no pattern match"
+ | elem cat [IntTok,FloatTok]
+ = NumberCode (showToken tok)
+ | elem cat [KW_case,KW_data,KW_do,KW_else,KW_external,
+ KW_free,KW_if,KW_import,KW_in,KW_infix,KW_infixl,KW_infixr,
+ KW_let,KW_module,KW_newtype,KW_of,KW_then,KW_type,
+ KW_where,Id_as,Id_ccall,Id_forall,Id_hiding,Id_interface,Id_primitive,
+ Id_qualified]
+ = Keyword (showToken tok)
+ | elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,
+ RightBracket,Comma,Underscore,Backquote,
+ At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
+ Tilde]
+ = Symbol (showToken tok)
+ | elem cat [LineComment, NestedComment]
+ = Commentary (showToken tok)
+ | isTokenIdentifier tok
+ = Identifier UnknownId $ qualify $ mkIdent $ showToken tok
+ | cat == StringTok
+ = StringCode (showToken tok)
+ | cat == CharTok
+ = CharCode (showToken tok)
+ | elem cat [EOF,VSemicolon,VRightBrace] = Space 0
+ | otherwise = error "SyntaxColoring.token2code: no pattern match"
isTokenIdentifier :: Token -> Bool
isTokenIdentifier (Token cat _) =
@@ -461,7 +404,6 @@ declPos (ExternalDecl p _ ) = p
declPos (PatternDecl p _ _ ) = p
declPos (FreeDecl p _ ) = p
-
lessDecl :: Decl -> Decl -> Bool
lessDecl = (<) `on` declPos
@@ -485,17 +427,16 @@ mergeExports2codes :: [Export] -> [Export] -> [Code]
mergeExports2codes [] _ = []
mergeExports2codes (e:es) xs = concatMap (export2codes xs) (e:es)
-
export2codes :: [Export] -> Export -> [Code]
-export2codes exports (Export qualIdent)
+export2codes exports (Export qid)
| length (filter checkDouble exports) /= 1 =
- [Identifier UnknownId qualIdent]
+ [Identifier UnknownId qid]
| otherwise =
let [export] = (filter checkDouble exports) in
export2c export
where
- checkDouble (ExportTypeWith q _) = eqQualIdent qualIdent q
- checkDouble (Export q) = eqQualIdent qualIdent q
+ checkDouble (ExportTypeWith q _) = eqQualIdent qid q
+ checkDouble (Export q) = eqQualIdent qid q
checkDouble _ = False
eqQualIdent q1 q2
@@ -503,290 +444,287 @@ export2codes exports (Export qualIdent)
| not (isQualified q1) = unqualify q1 == unqualify q2
| otherwise = False
- export2c (Export qualIdent1) =
- [Function OtherFunctionKind qualIdent1]
+ export2c (Export qid1) =
+ [Function OtherFunctionKind qid1]
export2c _ =
- [TypeConstructor TypeExport qualIdent]
+ [TypeConstructor TypeExport qid]
-export2codes _ (ExportTypeWith qualIdent idents) =
- TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents
-export2codes _ (ExportTypeAll qualIdent) =
- [TypeConstructor TypeExport qualIdent]
-export2codes _ (ExportModule moduleIdent) =
- [ModuleName moduleIdent]
+export2codes _ (ExportTypeWith qid idents) =
+ TypeConstructor TypeExport qid : map (Function OtherFunctionKind . qualify) idents
+export2codes _ (ExportTypeAll qid) =
+ [TypeConstructor TypeExport qid]
+export2codes _ (ExportModule mid) =
+ [ModuleName mid]
importDecl2codes :: ImportDecl -> [Code]
-importDecl2codes (ImportDecl _ moduleIdent _ mModuleIdent importSpec) =
- [ModuleName moduleIdent] ++
+importDecl2codes (ImportDecl _ mid _ mModuleIdent importSpec) =
+ [ModuleName mid] ++
maybe [] ((:[]) . ModuleName) mModuleIdent ++
- maybe [] (importSpec2codes moduleIdent) importSpec
+ maybe [] (importSpec2codes mid) importSpec
decl2codes :: Decl -> [Code]
-decl2codes (InfixDecl _ _ _ idents) =
- map (Function InfixFunction . qualify) idents
-decl2codes (DataDecl _ ident idents constrDecls) =
- TypeConstructor TypeDecla (qualify ident) :
- map (Identifier UnknownId . qualify) idents ++
- concatMap constrDecl2codes constrDecls
-decl2codes (NewtypeDecl _ _ _ _) =
- []
-decl2codes (TypeDecl _ ident idents typeExpr) =
- TypeConstructor TypeDecla (qualify ident) :
- map (Identifier UnknownId . qualify) idents ++
- typeExpr2codes typeExpr
-decl2codes (TypeSig _ idents typeExpr) =
- map (Function TypSig . qualify) idents ++ typeExpr2codes typeExpr
-decl2codes (FunctionDecl _ _ equations) =
- concatMap equation2codes equations
-decl2codes (ForeignDecl _ _ _ _ _) =
- []
-decl2codes (ExternalDecl _ idents) =
- map (Function FunDecl . qualify) idents
-decl2codes (PatternDecl _ constrTerm rhs) =
- constrTerm2codes constrTerm ++ rhs2codes rhs
-decl2codes (FreeDecl _ idents) =
- map (Identifier IdDecl . qualify) idents
+decl2codes (InfixDecl _ _ _ ops) = map (Function InfixFunction . qualify) ops
+decl2codes (DataDecl _ d vs cds) =
+ TypeConstructor TypeDecla (qualify d) :
+ map (Identifier UnknownId . qualify) vs ++
+ concatMap constrDecl2codes cds
+decl2codes (NewtypeDecl _ _ _ _) = []
+decl2codes (TypeDecl _ t vs ty) =
+ TypeConstructor TypeDecla (qualify t) :
+ map (Identifier UnknownId . qualify) vs ++
+ typeExpr2codes ty
+decl2codes (TypeSig _ fs ty) =
+ map (Function TypSig . qualify) fs ++ typeExpr2codes ty
+decl2codes (FunctionDecl _ _ eqs) = concatMap equation2codes eqs
+decl2codes (ForeignDecl _ _ _ _ _) = []
+decl2codes (ExternalDecl _ fs) = map (Function FunDecl . qualify) fs
+decl2codes (PatternDecl _ p rhs) = pat2codes p ++ rhs2codes rhs
+decl2codes (FreeDecl _ vs) = map (Identifier IdDecl . qualify) vs
equation2codes :: Equation -> [Code]
-equation2codes (Equation _ lhs rhs) =
- lhs2codes lhs ++ rhs2codes rhs
+equation2codes (Equation _ lhs rhs) = lhs2codes lhs ++ rhs2codes rhs
lhs2codes :: Lhs -> [Code]
-lhs2codes (FunLhs ident constrTerms) =
- Function FunDecl (qualify ident) : concatMap constrTerm2codes constrTerms
-lhs2codes (OpLhs constrTerm1 ident constrTerm2) =
- constrTerm2codes constrTerm1 ++ [Function FunDecl $ qualify ident] ++ constrTerm2codes constrTerm2
-lhs2codes (ApLhs lhs constrTerms) =
- lhs2codes lhs ++ concatMap constrTerm2codes constrTerms
+lhs2codes (FunLhs f ps) = Function FunDecl (qualify f) : concatMap pat2codes ps
+lhs2codes (OpLhs p1 op p2) = pat2codes p1 ++ [Function FunDecl $ qualify op] ++ pat2codes p2
+lhs2codes (ApLhs lhs ps) = lhs2codes lhs ++ concatMap pat2codes ps
rhs2codes :: Rhs -> [Code]
-rhs2codes (SimpleRhs _ expression decls) =
- expression2codes expression ++ concatMap decl2codes decls
-rhs2codes (GuardedRhs condExprs decls) =
- concatMap condExpr2codes condExprs ++ concatMap decl2codes decls
+rhs2codes (SimpleRhs _ e ds) = expr2codes e ++ concatMap decl2codes ds
+rhs2codes (GuardedRhs ce ds) = concatMap condExpr2codes ce ++ concatMap decl2codes ds
condExpr2codes :: CondExpr -> [Code]
-condExpr2codes (CondExpr _ expression1 expression2) =
- expression2codes expression1 ++ expression2codes expression2
-
-constrTerm2codes :: Pattern -> [Code]
-constrTerm2codes (LiteralPattern _) = []
-constrTerm2codes (NegativePattern _ _) = []
-constrTerm2codes (VariablePattern ident) = [Identifier IdDecl (qualify ident)]
-constrTerm2codes (ConstructorPattern qualIdent constrTerms) =
- ConstructorName ConstrPattern qualIdent : concatMap constrTerm2codes constrTerms
-constrTerm2codes (InfixPattern constrTerm1 qualIdent constrTerm2) =
- constrTerm2codes constrTerm1 ++ [ConstructorName ConstrPattern qualIdent] ++ constrTerm2codes constrTerm2
-constrTerm2codes (ParenPattern constrTerm) = constrTerm2codes constrTerm
-constrTerm2codes (TuplePattern _ constrTerms) = concatMap constrTerm2codes constrTerms
-constrTerm2codes (ListPattern _ constrTerms) = concatMap constrTerm2codes constrTerms
-constrTerm2codes (AsPattern ident constrTerm) =
- Function OtherFunctionKind (qualify ident) : constrTerm2codes constrTerm
-constrTerm2codes (LazyPattern _ constrTerm) = constrTerm2codes constrTerm
-constrTerm2codes (FunctionPattern qualIdent constrTerms) =
- Function OtherFunctionKind qualIdent : concatMap constrTerm2codes constrTerms
-constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =
- constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2
-constrTerm2codes (RecordPattern _ _) =
- internalError "SyntaxColoring.constrTerm2codes: record pattern"
-
-expression2codes :: Expression -> [Code]
-expression2codes (Literal _) = []
-expression2codes (Variable qualIdent) =
- [Identifier IdOccur qualIdent]
-expression2codes (Constructor qualIdent) =
- [ConstructorName ConstrCall qualIdent]
-expression2codes (Paren expression) =
- expression2codes expression
-expression2codes (Typed expression typeExpr) =
- expression2codes expression ++ typeExpr2codes typeExpr
-expression2codes (Tuple _ expressions) =
- concatMap expression2codes expressions
-expression2codes (List _ expressions) =
- concatMap expression2codes expressions
-expression2codes (ListCompr _ expression statements) =
- expression2codes expression ++ concatMap statement2codes statements
-expression2codes (EnumFrom expression) =
- expression2codes expression
-expression2codes (EnumFromThen expression1 expression2) =
- expression2codes expression1 ++ expression2codes expression2
-expression2codes (EnumFromTo expression1 expression2) =
- expression2codes expression1 ++ expression2codes expression2
-expression2codes (EnumFromThenTo expression1 expression2 expression3) =
- expression2codes expression1 ++
- expression2codes expression2 ++
- expression2codes expression3
-expression2codes (UnaryMinus ident expression) =
- Symbol (idName ident) : expression2codes expression
-expression2codes (Apply expression1 expression2) =
- expression2codes expression1 ++ expression2codes expression2
-expression2codes (InfixApply expression1 infixOp expression2) =
- expression2codes expression1 ++ infixOp2codes infixOp ++ expression2codes expression2
-expression2codes (LeftSection expression infixOp) =
- expression2codes expression ++ infixOp2codes infixOp
-expression2codes (RightSection infixOp expression) =
- infixOp2codes infixOp ++ expression2codes expression
-expression2codes (Lambda _ constrTerms expression) =
- concatMap constrTerm2codes constrTerms ++ expression2codes expression
-expression2codes (Let decls expression) =
- concatMap decl2codes decls ++ expression2codes expression
-expression2codes (Do statements expression) =
- concatMap statement2codes statements ++ expression2codes expression
-expression2codes (IfThenElse _ expression1 expression2 expression3) =
- expression2codes expression1 ++ expression2codes expression2 ++ expression2codes expression3
-expression2codes (Case _ _ expression alts) =
- expression2codes expression ++ concatMap alt2codes alts
-expression2codes _ = internalError "SyntaxColoring.expression2codes: no pattern match"
+condExpr2codes (CondExpr _ e1 e2) = expr2codes e1 ++ expr2codes e2
+
+pat2codes :: Pattern -> [Code]
+pat2codes (LiteralPattern _) = []
+pat2codes (NegativePattern _ _) = []
+pat2codes (VariablePattern v) = [Identifier IdDecl (qualify v)]
+pat2codes (ConstructorPattern qid ps)
+ = ConstructorName ConstrPattern qid : concatMap pat2codes ps
+pat2codes (InfixPattern p1 qid p2)
+ = pat2codes p1 ++ [ConstructorName ConstrPattern qid] ++ pat2codes p2
+pat2codes (ParenPattern p) = pat2codes p
+pat2codes (TuplePattern _ ps) = concatMap pat2codes ps
+pat2codes (ListPattern _ ps) = concatMap pat2codes ps
+pat2codes (AsPattern v p)
+ = Function OtherFunctionKind (qualify v) : pat2codes p
+pat2codes (LazyPattern _ p) = pat2codes p
+pat2codes (FunctionPattern qid ps)
+ = Function OtherFunctionKind qid : concatMap pat2codes ps
+pat2codes (InfixFuncPattern p1 f p2)
+ = pat2codes p1 ++ [Function InfixFunction f] ++ pat2codes p2
+pat2codes (RecordPattern _ _) =
+ internalError "SyntaxColoring.pat2codes: record pattern"
+
+expr2codes :: Expression -> [Code]
+expr2codes (Literal _) = []
+expr2codes (Variable qid) = [Identifier IdOccur qid]
+expr2codes (Constructor qid) = [ConstructorName ConstrCall qid]
+expr2codes (Paren e) = expr2codes e
+expr2codes (Typed e ty) = expr2codes e ++ typeExpr2codes ty
+expr2codes (Tuple _ es) = concatMap expr2codes es
+expr2codes (List _ es) = concatMap expr2codes es
+expr2codes (ListCompr _ e stmts) = expr2codes e ++ concatMap statement2codes stmts
+expr2codes (EnumFrom e) = expr2codes e
+expr2codes (EnumFromThen e1 e2) = concatMap expr2codes [e1,e2]
+expr2codes (EnumFromTo e1 e2) = concatMap expr2codes [e1,e2]
+expr2codes (EnumFromThenTo e1 e2 e3) = concatMap expr2codes [e1,e2,e3]
+expr2codes (UnaryMinus ident e) = Symbol (idName ident) : expr2codes e
+expr2codes (Apply e1 e2) = expr2codes e1 ++ expr2codes e2
+expr2codes (InfixApply e1 op e2) = expr2codes e1 ++ infixOp2codes op ++ expr2codes e2
+expr2codes (LeftSection e op) = expr2codes e ++ infixOp2codes op
+expr2codes (RightSection op e) = infixOp2codes op ++ expr2codes e
+expr2codes (Lambda _ ps e) = concatMap pat2codes ps ++ expr2codes e
+expr2codes (Let ds e) = concatMap decl2codes ds ++ expr2codes e
+expr2codes (Do stmts e) = concatMap statement2codes stmts ++ expr2codes e
+expr2codes (IfThenElse _ e1 e2 e3) = concatMap expr2codes [e1,e2,e3]
+expr2codes (Case _ _ e alts) = expr2codes e ++ concatMap alt2codes alts
+expr2codes _ = internalError "SyntaxColoring.expr2codes: no pattern match"
infixOp2codes :: InfixOp -> [Code]
-infixOp2codes (InfixOp qualIdent) = [Function InfixFunction qualIdent]
-infixOp2codes (InfixConstr qualIdent) = [ConstructorName OtherConstrKind qualIdent]
-
+infixOp2codes (InfixOp qid) = [Function InfixFunction qid]
+infixOp2codes (InfixConstr qid) = [ConstructorName OtherConstrKind qid]
statement2codes :: Statement -> [Code]
-statement2codes (StmtExpr _ expression) =
- expression2codes expression
-statement2codes (StmtDecl decls) =
- concatMap decl2codes decls
-statement2codes (StmtBind _ constrTerm expression) =
- constrTerm2codes constrTerm ++ expression2codes expression
-
+statement2codes (StmtExpr _ e) = expr2codes e
+statement2codes (StmtDecl ds) = concatMap decl2codes ds
+statement2codes (StmtBind _ p e) = pat2codes p ++ expr2codes e
alt2codes :: Alt -> [Code]
-alt2codes (Alt _ constrTerm rhs) =
- constrTerm2codes constrTerm ++ rhs2codes rhs
+alt2codes (Alt _ p rhs) = pat2codes p ++ rhs2codes rhs
constrDecl2codes :: ConstrDecl -> [Code]
-constrDecl2codes (ConstrDecl _ _ ident typeExprs) =
- ConstructorName ConstrDecla (qualify ident) : concatMap typeExpr2codes typeExprs
-constrDecl2codes (ConOpDecl _ _ typeExpr1 ident typeExpr2) =
- typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2
-
+constrDecl2codes (ConstrDecl _ _ c tys)
+ = ConstructorName ConstrDecla (qualify c) : concatMap typeExpr2codes tys
+constrDecl2codes (ConOpDecl _ _ ty1 op ty2)
+ = typeExpr2codes ty1 ++ [ConstructorName ConstrDecla $ qualify op] ++ typeExpr2codes ty2
importSpec2codes :: ModuleIdent -> ImportSpec -> [Code]
-importSpec2codes moduleIdent (Importing _ imports) = concatMap (import2codes moduleIdent) imports
-importSpec2codes moduleIdent (Hiding _ imports) = concatMap (import2codes moduleIdent) imports
+importSpec2codes mid (Importing _ is) = concatMap (import2codes mid) is
+importSpec2codes mid (Hiding _ is) = concatMap (import2codes mid) is
import2codes :: ModuleIdent -> Import -> [Code]
-import2codes moduleIdent (Import ident) =
- [Function OtherFunctionKind $ qualifyWith moduleIdent ident]
-import2codes moduleIdent (ImportTypeWith ident idents) =
- ConstructorName OtherConstrKind (qualifyWith moduleIdent ident) :
- map (Function OtherFunctionKind . qualifyWith moduleIdent) idents
-import2codes moduleIdent (ImportTypeAll ident) =
- [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident]
+import2codes mid (Import ident) =
+ [Function OtherFunctionKind $ qualifyWith mid ident]
+import2codes mid (ImportTypeWith ident idents) =
+ ConstructorName OtherConstrKind (qualifyWith mid ident) :
+ map (Function OtherFunctionKind . qualifyWith mid) idents
+import2codes mid (ImportTypeAll ident) =
+ [ConstructorName OtherConstrKind $ qualifyWith mid ident]
typeExpr2codes :: TypeExpr -> [Code]
-typeExpr2codes (ConstructorType qualIdent typeExprs) =
- TypeConstructor TypeUse qualIdent : concatMap typeExpr2codes typeExprs
-typeExpr2codes (VariableType ident) =
- [Identifier IdOccur (qualify ident)]
-typeExpr2codes (TupleType typeExprs) =
- concatMap typeExpr2codes typeExprs
-typeExpr2codes (ListType typeExpr) =
- typeExpr2codes typeExpr
-typeExpr2codes (ArrowType typeExpr1 typeExpr2) =
- typeExpr2codes typeExpr1 ++ typeExpr2codes typeExpr2
-typeExpr2codes (RecordType _ _) = internalError "SyntaxColoring.typeExpr2codes: Record pattern"
-
--- TOKEN TO STRING ------------------------------------------------------------
-token2string :: Token -> [Char]
-token2string (Token Id a) = attributes2string a
-token2string (Token QId a) = attributes2string a
-token2string (Token Sym a) = attributes2string a
-token2string (Token QSym a) = attributes2string a
-token2string (Token IntTok a) = attributes2string a
-token2string (Token FloatTok a) = attributes2string a
-token2string (Token CharTok a) = attributes2string a
-token2string (Token StringTok a) = attributes2string a
-token2string (Token LeftParen _) = "("
-token2string (Token RightParen _) = ")"
-token2string (Token Semicolon _) = ";"
-token2string (Token LeftBrace _) = "{"
-token2string (Token RightBrace _) = "}"
-token2string (Token LeftBracket _) = "["
-token2string (Token RightBracket _) = "]"
-token2string (Token Comma _) = ","
-token2string (Token Underscore _) = "_"
-token2string (Token Backquote _) = "`"
-token2string (Token VSemicolon _) = ""
-token2string (Token VRightBrace _) = ""
-token2string (Token At _) = "@"
-token2string (Token Colon _) = ":"
-token2string (Token DotDot _) = ".."
-token2string (Token DoubleColon _) = "::"
-token2string (Token Equals _) = "="
-token2string (Token Backslash _) = "\\"
-token2string (Token Bar _) = "|"
-token2string (Token LeftArrow _) = "<-"
-token2string (Token RightArrow _) = "->"
-token2string (Token Tilde _) = "~"
-token2string (Token SymDot _) = "."
-token2string (Token SymMinus _) = "-"
-token2string (Token SymMinusDot _) = "-."
-token2string (Token KW_case _) = "case"
-token2string (Token KW_data _) = "data"
-token2string (Token KW_do _) = "do"
-token2string (Token KW_else _) = "else"
-token2string (Token KW_external _) = "external"
-token2string (Token KW_fcase _) = "fcase"
-token2string (Token KW_foreign _) = "foreign"
-token2string (Token KW_free _) = "free"
-token2string (Token KW_if _) = "if"
-token2string (Token KW_import _) = "import"
-token2string (Token KW_in _) = "in"
-token2string (Token KW_infix _) = "infix"
-token2string (Token KW_infixl _) = "infixl"
-token2string (Token KW_infixr _) = "infixr"
-token2string (Token KW_let _) = "let"
-token2string (Token KW_module _) = "module"
-token2string (Token KW_newtype _) = "newtype"
-token2string (Token KW_of _) = "of"
-token2string (Token KW_then _) = "then"
-token2string (Token KW_type _) = "type"
-token2string (Token KW_where _) = "where"
-token2string (Token Id_as _) = "as"
-token2string (Token Id_ccall _) = "ccall"
-token2string (Token Id_forall _) = "forall"
-token2string (Token Id_hiding _) = "hiding"
-token2string (Token Id_interface _) = "interface"
-token2string (Token Id_primitive _) = "primitive"
-token2string (Token Id_qualified _) = "qualified"
-token2string (Token EOF _) = ""
-token2string (Token LineComment (StringAttributes sv _)) = sv
-token2string (Token LineComment a) = attributes2string a
-token2string (Token NestedComment (StringAttributes sv _)) = sv
-token2string (Token NestedComment a) = attributes2string a
-token2string (Token LeftBraceSemicolon _) = "{;"
-token2string (Token Bind _) = ":="
-token2string (Token Select _) = ":>"
-
-attributes2string :: Attributes -> [Char]
-attributes2string NoAttributes = ""
-attributes2string (CharAttributes cv _) = showCh cv
-attributes2string (IntAttributes iv _) = show iv
-attributes2string (FloatAttributes fv _) = show fv
-attributes2string (StringAttributes sv _) = showSt sv
-attributes2string (IdentAttributes mid i) = intercalate "." $ mid ++ [i]
-
-showCh :: Char -> [Char]
-showCh c
- | c == '\\' = "'\\\\'"
- | elem c ('\127' : ['\001' .. '\031']) = show c
- | otherwise = toString c
- where
- toString c' = '\'' : c' : "'"
+typeExpr2codes (ConstructorType qid tys)
+ = TypeConstructor TypeUse qid : concatMap typeExpr2codes tys
+typeExpr2codes (VariableType v) = [Identifier IdOccur (qualify v)]
+typeExpr2codes (TupleType tys) = concatMap typeExpr2codes tys
+typeExpr2codes (ListType ty) = typeExpr2codes ty
+typeExpr2codes (ArrowType ty1 ty2) = concatMap typeExpr2codes [ty1, ty2]
+typeExpr2codes (RecordType _ _) = internalError "SyntaxColoring.typeExpr2codes: Record pattern"
+
+showToken :: Token -> [Char]
+showToken (Token Id a) = showAttr a
+showToken (Token QId a) = showAttr a
+showToken (Token Sym a) = showAttr a
+showToken (Token QSym a) = showAttr a
+showToken (Token IntTok a) = showAttr a
+showToken (Token FloatTok a) = showAttr a
+showToken (Token CharTok a) = showAttr a
+showToken (Token StringTok a) = showAttr a
+showToken (Token LeftParen _) = "("
+showToken (Token RightParen _) = ")"
+showToken (Token Semicolon _) = ";"
+showToken (Token LeftBrace _) = "{"
+showToken (Token RightBrace _) = "}"
+showToken (Token LeftBracket _) = "["
+showToken (Token RightBracket _) = "]"
+showToken (Token Comma _) = ","
+showToken (Token Underscore _) = "_"
+showToken (Token Backquote _) = "`"
+showToken (Token VSemicolon _) = ""
+showToken (Token LeftBraceSemicolon _) = "{;"
+showToken (Token VRightBrace _) = ""
+showToken (Token At _) = "@"
+showToken (Token Colon _) = ":"
+showToken (Token DotDot _) = ".."
+showToken (Token DoubleColon _) = "::"
+showToken (Token Equals _) = "="
+showToken (Token Backslash _) = "\\"
+showToken (Token Bar _) = "|"
+showToken (Token LeftArrow _) = "<-"
+showToken (Token RightArrow _) = "->"
+showToken (Token Tilde _) = "~"
+showToken (Token Bind _) = ":="
+showToken (Token Select _) = ":>"
+showToken (Token SymDot _) = "."
+showToken (Token SymMinus _) = "-"
+showToken (Token SymMinusDot _) = "-."
+showToken (Token KW_case _) = "case"
+showToken (Token KW_data _) = "data"
+showToken (Token KW_do _) = "do"
+showToken (Token KW_else _) = "else"
+showToken (Token KW_external _) = "external"
+showToken (Token KW_fcase _) = "fcase"
+showToken (Token KW_foreign _) = "foreign"
+showToken (Token KW_free _) = "free"
+showToken (Token KW_if _) = "if"
+showToken (Token KW_import _) = "import"
+showToken (Token KW_in _) = "in"
+showToken (Token KW_infix _) = "infix"
+showToken (Token KW_infixl _) = "infixl"
+showToken (Token KW_infixr _) = "infixr"
+showToken (Token KW_let _) = "let"
+showToken (Token KW_module _) = "module"
+showToken (Token KW_newtype _) = "newtype"
+showToken (Token KW_of _) = "of"
+showToken (Token KW_then _) = "then"
+showToken (Token KW_type _) = "type"
+showToken (Token KW_where _) = "where"
+showToken (Token Id_as _) = "as"
+showToken (Token Id_ccall _) = "ccall"
+showToken (Token Id_forall _) = "forall"
+showToken (Token Id_hiding _) = "hiding"
+showToken (Token Id_interface _) = "interface"
+showToken (Token Id_primitive _) = "primitive"
+showToken (Token Id_qualified _) = "qualified"
+showToken (Token EOF _) = ""
+showToken (Token LineComment (StringAttributes sv _)) = sv
+showToken (Token LineComment a ) = showAttr a
+showToken (Token NestedComment (StringAttributes sv _)) = sv
+showToken (Token NestedComment a) = showAttr a
+
+showAttr :: Attributes -> [Char]
+showAttr NoAttributes = ""
+showAttr (CharAttributes cv _) = showCharacter cv
+showAttr (IntAttributes iv _) = show iv
+showAttr (FloatAttributes fv _) = show fv
+showAttr (StringAttributes sv _) = showSt sv
+showAttr (IdentAttributes mid i) = intercalate "." $ mid ++ [i]
+
+showCharacter :: Char -> [Char]
+showCharacter c
+ | c == '\\' = "'\\\\'"
+ | c `elem` ('\127' : ['\001' .. '\031']) = show c
+ | otherwise = ['\'', c, '\'']
showSt :: [Char] -> [Char]
showSt = addQuotes . concatMap toGoodChar
- where
- addQuotes x = "\"" ++ x ++ "\""
+ where addQuotes x = "\"" ++ x ++ "\""
toGoodChar :: Char -> [Char]
toGoodChar c
- | c == '\\' = "\\\\"
- | elem c ('\127' : ['\001' .. '\031']) = justShow c
- | c == '"' = "\\\""
- | otherwise = c : ""
- where
- justShow = init . tail . show
+ | c == '\\' = "\\\\"
+ | c `elem` ('\127' : ['\001' .. '\031']) = justShow c
+ | c == '"' = "\\\""
+ | otherwise = [c]
+ where justShow = init . tail . show
+
+{-
+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
+-}
+
+{-
+setQualIdent :: Code -> QualIdent -> Code
+setQualIdent (Keyword str) _ = (Keyword str)
+setQualIdent (Space i) _ = (Space i)
+setQualIdent NewLine _ = NewLine
+setQualIdent (ConstructorName kind _) qid = (ConstructorName kind qid)
+setQualIdent (Function kind _) qid = (Function kind qid)
+setQualIdent (ModuleName mid) _ = (ModuleName mid)
+setQualIdent (Commentary str) _ = (Commentary str)
+setQualIdent (NumberCode str) _ = (NumberCode str)
+setQualIdent (Symbol str) _ = (Symbol str)
+setQualIdent (Identifier kind _) qid = (Identifier kind qid)
+setQualIdent (TypeConstructor kind _) qid = (TypeConstructor kind qid)
+setQualIdent (StringCode str) _ = (StringCode str)
+setQualIdent (CharCode str) _ = (CharCode str)
+-}
+
+-- --- @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"
\ No newline at end of file