Commit dac70ef7 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Fixed linking for identifiers in Curry HTML documentation

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