module SyntaxColoring (Program,Code(..),TypeKind(..),ConstructorKind(..),
IdentifierKind(..),FunctionKind(..),filename2program,
code2string,getQualIdent, position2code,
area2codes) where
import Debug.Trace
import Data.Maybe
import Data.List
import CurryLexer
import Position
import Frontend
import Ident
import CurrySyntax
import Data.Char hiding(Space)
import Message
import Control.Exception
import PathUtils (readModule)
debug = False -- mergen von Token und Codes
trace' s x = if debug then trace s x else x
debug' = False -- messages
trace'' s x = if debug' then trace s x else x
debug'' = False -- parseResults und codes
trace''' s x = if debug'' then trace s x else x
type Program = [(Int,Int,Code)]
data Code = Keyword String
| Space Int
| NewLine
| ConstructorName ConstructorKind QualIdent
| TypeConstructor TypeKind QualIdent
| Function FunctionKind QualIdent
| ModuleName ModuleIdent
| Commentary String
| NumberCode String
| StringCode String
| CharCode String
| Symbol String
| Identifier IdentifierKind QualIdent
| CodeWarning [Message] Code
| CodeError [Message] Code
| NotParsed String deriving Show
data TypeKind = TypeDecla
| TypeUse
| TypeExport deriving Show
data ConstructorKind = ConstrPattern
| ConstrCall
| ConstrDecla
| OtherConstrKind deriving Show
data IdentifierKind = IdDecl
| IdOccur
| UnknownId deriving Show
data FunctionKind = InfixFunction
| TypSig
| FunDecl
| FunctionCall
| OtherFunctionKind deriving Show
--- @param importpaths
--- @param filename
--- @return program
filename2program :: [String] -> String -> IO Program
filename2program paths filename=
readModule filename >>= \ cont ->
(catchError show (typingParse paths filename cont)) >>= \ typingParseResult ->
(catchError show (fullParse paths filename cont)) >>= \ fullParseResult ->
(catchError show (return (parse filename cont))) >>= \ parseResult ->
(catchError show (return (Frontend.lex filename cont))) >>= \ lexResult ->
return (genProgram cont (typingParseResult : fullParseResult : [parseResult]) lexResult)
--- @param plaintext
--- @param list with parse-Results with descending quality e.g. [typingParse,fullParse,parse]
--- @param lex-Result
--- @return program
genProgram :: String -> [Result Module] -> Result [(Position,Token)] -> Program
genProgram _ parseResults (Result mess posNtokList) =
let messages = (prepareMessages
(concatMap getMessages parseResults ++
mess))
mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages)
posNtokList)
(nameList,codes) = catIdentifiers parseResults in
trace''' ("parseResults : " ++ show parseResults ++ "\n\nCodes: " ++ show codes ++ "\n\nToken: " ++ show mergedMessages)
(tokenNcodes2codes
nameList
1
1
mergedMessages
codes)
genProgram plainText parseResults (Failure messages) =
trace' (unlines (map (\(Message _ _ str) -> str) allMessages))
(buildMessagesIntoPlainText allMessages plainText)
where
allMessages = prepareMessages (concatMap getMessages parseResults ++
messages)
--- @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,_):_)) line col
| line == l && col >= c && col < c2 = Just code
| l > line = Nothing
| otherwise = position2code xs line col
area2codes :: Program -> Position -> Position -> [Code]
area2codes [] _ _ = []
area2codes xxs@((l,c,code):xs) p1@Position{file=file} 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 file l c noRef
posEnd = Position file l (c + (length (code2string code))) noRef
--- this function intercepts errors and converts it to Messages
--- @param a show-function for (Result a)
--- @param a function that generates a (Result a)
--- @return (Result a) without runtimeerrors
catchError :: (Result a -> String) -> IO (Result a) -> IO (Result a)
catchError toString toDo = Control.Exception.catch (toDo >>= returnComplete toString) handler
where
handler (ErrorCall str) = return (Failure [setMessagePosition (Message Error Nothing str)])
handler e = return (Failure [Message Error Nothing (show e)])
returnComplete :: (a -> String) -> a -> IO a
returnComplete toString a = f (toString a) (return a)
where
f [] r = r
f (_:xs) r = f xs r
--- @param code
--- @return qualIdent 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
-- privates-----------------------------------------------------------------------------------
codeWithoutPos :: (Int,Int,Code) -> Code
codeWithoutPos (_,_,c) = c
-- DEBUGGING----------- wird bald nicht mehr gebraucht
setMessagePosition :: Message -> Message
setMessagePosition m@(Message _ (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
setMessagePosition (Message typ _ m) =
let mes@(Message _ pos _) = (Message typ (getPositionFromString m) m) in
trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes
getPositionFromString :: String -> Maybe Position
getPositionFromString message =
if line > 0 && col > 0
then Just Position{file=file,line=line,column=col,ast=noRef}
else Nothing
where
file = takeWhile (/= '"') (tail (dropWhile (/= '"') message))
line = readInt (takeWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))
col = readInt (takeWhile (/= ':') (tail (dropWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))))
readInt :: String -> Int
readInt s =
let onlyNum = filter isDigit s in
if null onlyNum
then 0
else read onlyNum :: Int
-- -------------------------
-- -------------------------
flatCode :: Code -> Code
flatCode (CodeWarning _ code) = code
flatCode (CodeError _ code) = code
flatCode code = code
-- ----------Message---------------------------------------
getMessages :: Result a -> [Message]
getMessages (Result mess _) = mess
getMessages (Failure mess) = mess
lessMessage :: Message -> Message -> Bool
lessMessage (Message _ mPos1 _) (Message _ mPos2 _) = mPos1 < mPos2
nubMessages :: [Message] -> [Message]
nubMessages = nubBy eqMessage
eqMessage :: Message -> Message -> Bool
eqMessage (Message f1 p1 s1) (Message f2 p2 s2) = (f1 == f2) && (p1 == p2) && (s1 == s2)
prepareMessages :: [Message] -> [Message]
prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
hasError [] = False
hasError ((Message Error _ _):ms) = True
hasError (_:ms) = hasError ms
buildMessagesIntoPlainText :: [Message] -> String -> Program
buildMessagesIntoPlainText messages text =
buildMessagesIntoPlainText' messages (lines text) [] 1
where
buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' _ [] [] _ =
[]
buildMessagesIntoPlainText' _ [] postStrs line =
[(line,1,NotParsed (unlines postStrs))]
buildMessagesIntoPlainText' [] preStrs postStrs line =
[(line,1,NotParsed (unlines (preStrs ++ postStrs)))]
buildMessagesIntoPlainText' messages (str:preStrs) postStrs ln =
let (pre,post) = partition isLeq messages in
if null pre
then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)
else (ln,1,NotParsed (unlines postStrs)) :
(if hasError pre then (ln,1,CodeError pre (NotParsed str)) : [(ln,1,NewLine)]
else (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 :: [Result Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers [] = ([],[])
catIdentifiers [(Failure _)] = ([],[])
catIdentifiers [(Result _ m@(Module moduleIdent maybeExportSpec decls))] =
catIdentifiers' m Nothing
catIdentifiers ((Failure _):y:ys) =
catIdentifiers (y:ys)
catIdentifiers rs@((Result _ m@(Module _ _ _)):y:ys) =
catIdentifiers' (getLastModule (reverse rs)) (Just m)
where
getLastModule ((Failure _):xs) = getLastModule xs
getLastModule ((Result _ m@(Module _ _ _)):_) = m
--- @param parse-Module
--- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers' (Module moduleIdent maybeExportSpec decls)
Nothing =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
([ModuleName moduleIdent] ++
(maybe [] exportSpec2codes maybeExportSpec) ++
codes))
catIdentifiers' (Module moduleIdent maybeExportSpec1 _)
(Just (Module _ maybeExportSpec2 decls)) =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
replaceFunctionCalls $
map (addModuleIdent moduleIdent) $
([ModuleName moduleIdent] ++
(mergeExports2codes
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec1)
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec2)) ++
codes))
renamedImports :: Decl -> [(ModuleIdent,ModuleIdent)]
renamedImports decl =
case decl of
(ImportDecl _ oldName _ (Just newName) _) -> [(oldName,newName)]
_ -> []
replaceFunctionCalls :: [Code] -> [Code]
replaceFunctionCalls codes = map (idOccur2functionCall qualIdents) codes
where
qualIdents = findFunctionDecls codes
findFunctionDecls :: [Code] -> [QualIdent]
findFunctionDecls = mapMaybe getQualIdent .
filter isFunctionDecl .
map flatCode
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 qualIdents (CodeError mess code) =
(CodeError mess (idOccur2functionCall qualIdents code))
idOccur2functionCall _ code = code
addModuleIdent :: ModuleIdent -> Code -> Code
addModuleIdent moduleIdent (Function x qualIdent)
| uniqueId (unqualify qualIdent) == 0 =
(Function x (qualQualify moduleIdent qualIdent))
| otherwise = (Function x qualIdent)
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 moduleIdent (CodeError mess code) =
(CodeError mess (addModuleIdent moduleIdent code))
addModuleIdent _ c = c
-- ----------------------------------------
mergeMessages :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
mergeMessages mess pos = mergeMessages' (prepareMessages mess) pos
mergeMessages' :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
mergeMessages' _ [] = []
mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps
mergeMessages' mss@(m@(Message _ mPos x):ms) ((p,t):ps)
| mPos <= Just p = (trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ 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,pos@Position{line=line,column=col},token):ts) codes
| currLine < line =
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 (line,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
newLine = (currLine + length (lines tokenStr)) - 1
newCol = currCol + length tokenStr
rename mid = Just $ maybe mid id (lookup mid nameList)
addMessage [] = []
addMessage ((l,c,code):cs)
| null messages = ((l,c,code):cs)
| hasError messages =
trace' ("Error bei code: " ++ show codes ++ ":" ++ show messages)
((l,c,CodeError messages code): addMessage cs)
| otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages)
((l,c,CodeWarning messages code): addMessage cs)
renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code
renameModuleIdents nameList c =
case c of
Function x qualIdent -> Function x (rename qualIdent (splitQualIdent qualIdent))
Identifier x qualIdent -> Identifier x (rename qualIdent (splitQualIdent qualIdent))
_ -> c
where
rename x (Nothing,_) = x
rename x (Just m,i) = maybe x (\ m' -> qualifyWith m' i) (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 [] moduleQualifiers . getModuleIdent
getModuleIdent :: Code -> Maybe ModuleIdent
getModuleIdent (ConstructorName _ qualIdent) = fst $ splitQualIdent qualIdent
getModuleIdent (Function _ qualIdent) = fst $ splitQualIdent qualIdent
getModuleIdent (ModuleName moduleIdent) = Just moduleIdent
getModuleIdent (Identifier _ qualIdent) = fst $ splitQualIdent qualIdent
getModuleIdent (TypeConstructor _ qualIdent) = fst $ splitQualIdent 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)
-}
code2string (Keyword str) = str
code2string (Space i)= concat (replicate i " ")
code2string NewLine = "\n"
code2string (ConstructorName _ qualIdent) = name $ unqualify qualIdent
code2string (Function _ qualIdent) = name $ unqualify qualIdent
code2string (ModuleName moduleIdent) = moduleName moduleIdent
code2string (Commentary str) = str
code2string (NumberCode str) = str
code2string (Symbol str) = str
code2string (Identifier _ qualIdent) = name $ unqualify qualIdent
code2string (TypeConstructor _ qualIdent) = name $ unqualify qualIdent
code2string (StringCode str) = str
code2string (CharCode str) = str
code2string (NotParsed str) = str
code2string _ = "" -- error / warning
code2qualString (ConstructorName _ qualIdent) = qualName qualIdent
code2qualString (Function _ qualIdent) = qualName qualIdent
code2qualString (Identifier _ qualIdent) = qualName qualIdent
code2qualString (TypeConstructor _ qualIdent) = qualName qualIdent
code2qualString x = code2string x
token2code :: Token -> Code
token2code tok@(Token cat _)
| elem cat [IntTok,FloatTok,IntegerTok]
= NumberCode (token2string tok)
| elem cat [KW_case,KW_choice,KW_data,KW_do,KW_else,KW_eval,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_rigid,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
isTokenIdentifier :: Token -> Bool
isTokenIdentifier (Token cat _) =
elem cat [Id,QId,Sym,QSym,Sym_Dot,Sym_Minus,Sym_MinusDot]
-- DECL Position
getPosition :: Decl -> Position
getPosition (ImportDecl pos _ _ _ _) = pos
getPosition (InfixDecl pos _ _ _) = pos
getPosition (DataDecl pos _ _ _) = pos
getPosition (NewtypeDecl pos _ _ _) = pos
getPosition (TypeDecl pos _ _ _) = pos
getPosition (TypeSig pos _ _) = pos
getPosition (EvalAnnot pos _ _) = pos
getPosition (FunctionDecl pos _ _) = pos
getPosition (ExternalDecl pos _ _ _ _) = pos
getPosition (FlatExternalDecl pos _) = pos
getPosition (PatternDecl pos _ _) = pos
getPosition (ExtraVariables pos _) = pos
lessDecl :: Decl -> Decl -> Bool
lessDecl decl1 decl2 = getPosition decl1 < getPosition decl2
qsort _ [] = []
qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]
-- DECL TO CODE --------------------------------------------------------------------
exportSpec2codes :: ExportSpec -> [Code]
exportSpec2codes (Exporting _ exports) = concatMap (export2codes []) exports
--- @param parse-Exports
--- @param betterParse-Exports
mergeExports2codes :: [Export] -> [Export] -> [Code]
mergeExports2codes [] _ = []
mergeExports2codes (e:es) xs = concatMap (export2codes xs) (e:es)
export2codes :: [Export] -> Export -> [Code]
export2codes exports e@(Export qualIdent)
| length (filter checkDouble exports) /= 1 =
[Identifier UnknownId qualIdent]
| otherwise =
let [export] = (filter checkDouble exports) in
export2c export
where
checkDouble (ExportTypeWith q _) = eqQualIdent qualIdent q
checkDouble (Export q) = eqQualIdent qualIdent q
checkDouble _ = False
eqQualIdent q1 q2
| q1 == q2 = True
| not (isQualified q1) = unqualify q1 == unqualify q2
| otherwise = False
export2c (Export qualIdent) =
[Function OtherFunctionKind qualIdent]
export2c _ =
[TypeConstructor TypeExport qualIdent]
export2codes _ (ExportTypeWith qualIdent idents) =
[TypeConstructor TypeExport qualIdent] ++ map (Function OtherFunctionKind . qualify) idents
export2codes _ (ExportTypeAll qualIdent) =
[TypeConstructor TypeExport qualIdent]
export2codes _ (ExportModule moduleIdent) =
[ModuleName moduleIdent]
decl2codes :: Decl -> [Code]
decl2codes (ImportDecl _ moduleIdent xQualified mModuleIdent importSpec) =
[ModuleName moduleIdent] ++
maybe [] ((:[]) . ModuleName) mModuleIdent ++
maybe [] (importSpec2codes moduleIdent) importSpec
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 xPosition xIdent yIdents xNewConstrDecl) =
[]
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 (EvalAnnot xPosition idents xEvalAnnotation) =
map (Function FunDecl . qualify) idents
decl2codes (FunctionDecl _ _ equations) =
concatMap equation2codes equations
decl2codes (ExternalDecl xPosition xCallConv xString xIdent xTypeExpr) =
[]
decl2codes (FlatExternalDecl _ idents) =
map (Function FunDecl . qualify) idents
decl2codes (PatternDecl xPosition constrTerm rhs) =
constrTerm2codes constrTerm ++ rhs2codes rhs
decl2codes (ExtraVariables _ idents) =
map (Identifier IdDecl . qualify) idents
equation2codes :: Equation -> [Code]
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
rhs2codes :: Rhs -> [Code]
rhs2codes (SimpleRhs _ expression decls) =
expression2codes expression ++ concatMap decl2codes decls
rhs2codes (GuardedRhs condExprs decls) =
concatMap condExpr2codes condExprs ++ concatMap decl2codes decls
condExpr2codes :: CondExpr -> [Code]
condExpr2codes (CondExpr _ expression1 expression2) =
expression2codes expression1 ++ expression2codes expression2
constrTerm2codes :: ConstrTerm -> [Code]
constrTerm2codes (LiteralPattern literal) = []
constrTerm2codes (NegativePattern ident literal) = []
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
expression2codes :: Expression -> [Code]
expression2codes (Literal 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 (name 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
infixOp2codes :: InfixOp -> [Code]
infixOp2codes (InfixOp qualIdent) = [Function InfixFunction qualIdent]
infixOp2codes (InfixConstr qualIdent) = [ConstructorName OtherConstrKind qualIdent]
statement2codes :: Statement -> [Code]
statement2codes (StmtExpr _ expression) =
expression2codes expression
statement2codes (StmtDecl decls) =
concatMap decl2codes decls
statement2codes (StmtBind _ constrTerm expression) =
constrTerm2codes constrTerm ++ expression2codes expression
alt2codes :: Alt -> [Code]
alt2codes (Alt _ constrTerm rhs) =
constrTerm2codes constrTerm ++ rhs2codes rhs
constrDecl2codes :: ConstrDecl -> [Code]
constrDecl2codes (ConstrDecl _ idents ident typeExprs) =
(ConstructorName ConstrDecla $ qualify ident) : concatMap typeExpr2codes typeExprs
constrDecl2codes (ConOpDecl _ idents typeExpr1 ident typeExpr2) =
typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2
importSpec2codes :: ModuleIdent -> ImportSpec -> [Code]
importSpec2codes moduleIdent (Importing _ imports) = concatMap (import2codes moduleIdent) imports
importSpec2codes moduleIdent (Hiding _ imports) = concatMap (import2codes moduleIdent) imports
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]
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
-- TOKEN TO STRING ------------------------------------------------------------
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 IntegerTok 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 Sym_Dot _) = "."
token2string (Token Sym_Minus _) = "-"
token2string (Token Sym_MinusDot _) = "-."
token2string (Token KW_case _) = "case"
token2string (Token KW_choice _) = "choice"
token2string (Token KW_data _) = "data"
token2string (Token KW_do _) = "do"
token2string (Token KW_else _) = "else"
token2string (Token KW_eval _) = "eval"
token2string (Token KW_external _) = "external"
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_rigid _) = "rigid"
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 sval _)) = sval
token2string (Token NestedComment (StringAttributes sval _)) = sval
attributes2string NoAttributes = ""
attributes2string (CharAttributes cval _) = showCh cval
attributes2string (IntAttributes ival _) = show ival
attributes2string (FloatAttributes fval _) = show fval
attributes2string (IntegerAttributes intval _) = show intval
attributes2string (StringAttributes sval _) = showSt sval
attributes2string (IdentAttributes mIdent ident) =concat (intersperse "." (mIdent ++ [ident]))
basename = reverse . takeWhile (/='/') . reverse
showCh c
| c == '\\' = "'\\\\'"
| elem c ('\127' : ['\001' .. '\031']) = show c
| otherwise = toString c
where
toString c = "'" ++ c : "'"
showSt = addQuotes . concatMap toGoodChar
where
addQuotes x = "\"" ++ x ++ "\""
toGoodChar c
| c == '\\' = "\\\\"
| elem c ('\127' : ['\001' .. '\031']) = justShow c
| c == '"' = "\\\""
| otherwise = c : ""
where
justShow = reverse . tail . reverse . tail . show