Comments.icl 10.9 KB
Newer Older
1 2 3 4 5 6
implementation module Clean.Parse.Comments

import StdArray
import StdBool
import StdChar
import StdClass
7
import StdFunctions
8 9
import StdInt
import StdList
10
import StdMisc
11 12 13 14 15 16
import StdString
import StdTuple

import Control.Monad
import Data.Error
import Data.Functor
Mart Lubbers's avatar
Mart Lubbers committed
17
from Data.Map import :: Map(..), newMap, put, get
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
import Data.Maybe
import System.File
import System.FilePath
from Text import class Text(startsWith), instance Text String

from Heap import :: Heap, :: HeapN, :: Ptr{pointer}, :: PtrN(Ptr), readPtr
from syntax import
	:: AttrVarInfo,
	:: AttrVarInfoPtr,
	:: AType,
	:: ATypeVar,
	:: BITVECT,
	:: CheckedTypeDef,
	:: ClassDef{class_ident,class_pos},
	:: ClassInstance,
33
	:: ClassInstanceR,
34 35 36
	:: CollectedDefinitions,
	:: ComponentNrAndIndex,
	:: ConsDef,
37
	:: DclInstanceMemberTypeAndFunction,
38 39 40 41 42 43
	:: Declaration,
	:: FileName,
	:: FunctionOrMacroIndex,
	:: FunctName,
	:: FunKind,
	:: FunSpecials,
44
	:: GenericDef{gen_ident,gen_pos},
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
	:: GenericCaseDef{gc_pos},
	:: Global,
	:: Ident{id_info,id_name},
	:: Import{import_file_position},
	:: ImportedObject,
	:: Index, :: LineNr,
	:: Module{mod_defs,mod_ident},
	:: ModuleN,
	:: Optional,
	:: ParsedConstructor{pc_cons_ident,pc_cons_pos},
	:: ParsedDefinition(..),
	:: ParsedExpr,
	:: ParsedImport,
	:: ParsedInstance{pi_pos},
	:: ParsedInstanceAndMembers{pim_pi},
	:: ParsedModule,
61
	:: ParsedSelector{ps_field_pos,ps_field_ident},
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
	:: ParsedTypeDef,
	:: Position(..),
	:: Priority,
	:: Rhs,
	:: RhsDefsOfType(..),
	:: SelectorDef,
	:: SortedQualifiedImports,
	:: STE_BoundTypeVariable,
	:: STE_Kind(..),
	:: SymbolPtr,
	:: SymbolTable,
	:: SymbolTableEntry{ste_kind},
	:: SymbolType,
	:: TypeDef{td_ident,td_pos,td_rhs},
	:: TypeRhs,
	:: TypeVarInfo,
	:: TypeVarInfoPtr,
	:: VarInfo,
	:: VarInfoPtr

scanComments :: !FilePath !*env -> *(!MaybeError FileError [CleanComment], !*env) | FileSystem env
scanComments fp w
# (s,w) = readFile fp w
| isError s = (Error (fromError s), w)
# s = fromOk s
# (cmnts,ss) = scan {defaultScanState & input=s}
= (Ok cmnts, w)

scanCommentsFile :: !*File -> *(!MaybeError FileError [CleanComment], !*File)
scanCommentsFile f
# (s,f) = readAll f
| isError s = (Error (fromError s), f)
# s = fromOk s
# (cmnts,ss) = scan {defaultScanState & input=s}
= (Ok cmnts, f)

:: ScanState =
	{ comment_level :: !Int
100
	, comment_idxs  :: ![(Int,Int,Int)] // line, col, idx
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
	, ln            :: !Int
	, col           :: !Int
	, input         :: !String
	, idx           :: !Int
	}

defaultScanState :: ScanState
defaultScanState =
	{ comment_level = 0
	, comment_idxs  = []
	, ln            = 1
	, col           = 0
	, input         = ""
	, idx           = 0
	}

advance :: !ScanState -> ScanState
advance ss = {ss & col=ss.col+1, idx=ss.idx+1}

scan :: !ScanState -> (![CleanComment], !ScanState)
scan ss=:{idx}
| idx >= size ss.input = ([], ss)
123 124 125 126 127
| otherwise = case [ss.input.[i] \\ i <- [idx..]] of
	['\r':_]
		-> scan (advance ss)
	['\n':_]
		-> scan {ss & idx=idx+1, ln=ss.ln+1, col=0}
128 129
	['\t':_] // We assume that there are no tabs within a line: each tab counts as 4 characters
		-> scan {ss & idx=idx+1, col=ss.col+4}
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
	['//':_] | ss.comment_level == 0
		# cmnt =
			{ line      = ss.ln
			, column    = ss.col
			, level     = Nothing
			, content   = ""
			, multiline = False
			}
		# ss = scan_to_newline ss
		# cmnt & content = ss.input % (idx+2,ss.idx-1)
		# (cmnts,ss) = scan ss
		-> ([cmnt:cmnts],ss)
	['/*':_]
		-> scan
			{ ss & idx=idx+2, col=ss.col+2
			, comment_level = ss.comment_level+1
			, comment_idxs  = [(ss.ln, ss.col, idx+2):ss.comment_idxs]
			}
	['*/':_] | ss.comment_level > 0
		# (c_ln,c_col,c_idx) = hd ss.comment_idxs
		# level = ss.comment_level
		# cmnt =
			{ line      = c_ln
			, column    = c_col
			, level     = Just level
			, content   = ss.input % (c_idx, idx-1)
			, multiline = True
			}
		# (cmnts,ss) = scan
			{ ss & idx=idx+2, col=ss.col+2
			, comment_level = ss.comment_level-1
			, comment_idxs  = tl ss.comment_idxs
			}
		# (before,after) = span (\c -> isJust c.level && fromJust c.level < level) cmnts
		-> (before ++ [cmnt:after],ss)
	['[':_] | ss.comment_level == 0
		-> scan (skip_list_literal (advance ss))
	['"':_] | ss.comment_level == 0
		-> scan (skip_string_literal '"' (advance ss))
	_
		-> scan (advance ss)
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190

scan_to_newline :: !ScanState -> ScanState
scan_to_newline ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
| c == '\n' = {ss & ln=ss.ln+1, col=0, idx=ss.idx+1}
| otherwise = scan_to_newline (advance ss)

skip_list_literal :: !ScanState -> ScanState
skip_list_literal ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
| isSpace c = skip_list_literal (advance ss)
| c == '\'' = skip_string_literal '\'' (advance ss)
| otherwise = ss

skip_string_literal :: !Char !ScanState -> ScanState
skip_string_literal term ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
191
| c == term = advance ss
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
| c == '\\' = skip_escape_sequence (advance ss)
| otherwise = skip_string_literal term (advance ss)
where
	skip_escape_sequence :: !ScanState -> ScanState
	skip_escape_sequence ss
	| ss.idx >= size ss.input = ss
	# [c1,c2,c3,c4:_] = [ss.input.[i] \\ i <- [ss.idx..]]
	= case c1 of
		'x'
			| isHexDigit c2
				| isHexDigit c3 -> iter 3 advance ss
				| otherwise -> twice advance ss
			| otherwise -> advance ss
		'0'
			| isOctDigit c2
				| isOctDigit c3
					| isOctDigit c4 -> iter 4 advance ss
					| otherwise -> iter 3 advance ss
				| otherwise -> twice advance ss
			| otherwise -> advance ss
		_ -> twice advance ss

214
:: CollectedComments :== Map CommentIndex CleanComment
215

216
:: CommentIndex = CI String Position String
217

218
instance < Position
219
where
220 221 222 223 224 225 226 227 228 229 230
	< a b = index a < index b
	where
		index (FunPos f l n) = (f,   l, n)
		index (LinePos f l)  = (f,   l, "")
		index (PreDefPos id) = ("", -1, id.id_name)
		index NoPos          = ("", -2, "")

instance < CommentIndex where < (CI a b c) (CI d e f) = (a,b,c) < (d,e,f)

putCC k v coll :== case commentIndex k of
	Nothing -> coll
Mart Lubbers's avatar
Mart Lubbers committed
231
	Just k  -> put k v coll
232 233

emptyCollectedComments :: CollectedComments
Mart Lubbers's avatar
Mart Lubbers committed
234
emptyCollectedComments = newMap
235

236
getComment :: !a !CollectedComments -> Maybe String | commentIndex a
Mart Lubbers's avatar
Mart Lubbers committed
237
getComment elem coll = (\cc -> cc.content) <$> (flip get coll =<< commentIndex elem)
238 239 240

collectComments :: ![CleanComment] !ParsedModule -> CollectedComments
collectComments comments pm
Mart Lubbers's avatar
Mart Lubbers committed
241
# coll = newMap
242 243 244
# (comments,coll) = case comments of
	[] -> ([], coll)
	[c:cs]
245 246
		| c.line <= 3 && startsWith "*" c.content -> (cs, putCC pm c coll)
		| otherwise -> (comments, coll)
247 248 249
# (_,_,coll) = collect comments Nothing pm.mod_defs coll
= coll

250
collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, singleLineAbove, commentIndex, children a
251 252 253 254 255 256
collect cc prev [] coll = (cc, prev, coll)
collect [] (Just prev) [pd:pds] coll = ([], Nothing, putCC pd prev coll)
collect [] Nothing _ coll = ([], Nothing, coll)
collect [{content}:cs] prev pds coll | not (startsWith "*" content) = collect cs prev pds coll
collect allcmnts=:[c:cs] prev allpds=:[pd:pds] coll = case c canBelongTo pd of
	Nothing -> collect allcmnts prev pds coll
257
	Just True -> case prev of
258
		Just prev | not (singleLineAbove pd) && not c.multiline
259
			# coll = putCC pd prev coll
260
			# (allcmnts,prev,coll) = recurse allcmnts Nothing (children pd) coll
261
			-> collect allcmnts prev pds coll
262 263
		_
			-> collect cs (Just c) allpds coll
264 265 266 267 268 269
	Just False
		# coll = case prev of
			Nothing -> coll
			Just cmnt -> putCC pd cmnt coll
		# (allcmnts,prev,coll) = recurse allcmnts Nothing (children pd) coll
		-> collect allcmnts prev pds coll
270 271 272 273
where
	// Compiler cannot figure out the overloading if we call collect from collect directly
	recurse :: ![CleanComment] !(Maybe CleanComment) !Children !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments)
	recurse cs prev (Children xs) coll = collect cs prev xs coll
274
collect _ _ _ _ = abort "internal error in Clean.Parse.Comments.collect\n"
275

276
:: Children = E.t: Children ![t] & pos, singleLineAbove, commentIndex, children t
277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294

class children a :: !a -> Children

instance children ParsedDefinition
where
	children pd = case pd of
		PD_Type ptd -> case ptd.td_rhs of
			ConsList cs -> Children cs
			ExtensibleConses cs -> Children cs
			MoreConses _ cs -> Children cs
			SelectorList _ _ _ ss -> Children ss
			_ -> Children (tl [pd]) // to fix the type
		PD_Class _ pds -> Children pds
		_ -> Children (tl [pd])

instance children ParsedSelector where children ps = Children (tl [ps])
instance children ParsedConstructor where children pc = Children (tl [pc])

295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos, singleLineAbove a
(canBelongTo) {line,column,multiline} elem
| singleLineAbove elem && column > 4
	= Just False
| not (singleLineAbove elem) && column < 4
	= Just False
	= pos elem >>= \p -> case p of
		FunPos _ ln _ -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
		LinePos _ ln  -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
		_             -> Nothing

// If true, single-line documentation should be given above the element.
class singleLineAbove a :: !a -> Bool
instance singleLineAbove ParsedDefinition  where singleLineAbove _ = True
instance singleLineAbove ParsedSelector    where singleLineAbove _ = False
instance singleLineAbove ParsedConstructor where singleLineAbove _ = False
311 312 313 314 315 316 317 318 319 320 321 322 323

class pos a :: !a -> Maybe Position

instance pos ParsedDefinition
where
	pos pd = case pd of
		PD_Function pos _ _ _ _ _ -> Just pos
		PD_NodeDef pos _ _ -> Just pos
		PD_Type ptd -> Just ptd.td_pos
		PD_TypeSpec pos _ _ _ _ -> Just pos
		PD_Class cd _ -> Just cd.class_pos
		PD_Instance piam -> Just piam.pim_pi.pi_pos
		PD_Instances [piam:_] -> Just piam.pim_pi.pi_pos
324
		PD_Instances [] -> Nothing
325
		PD_Import [pi:_] -> Just pi.import_file_position
326
		PD_Import [] -> Nothing
327 328 329 330 331
		PD_ImportedObjects _ -> Nothing
		PD_ForeignExport _ _ _ _ -> Nothing
		PD_Generic gd -> Just gd.gen_pos
		PD_GenericCase gcd _ -> Just gcd.gc_pos
		PD_Derive [gcd:_] -> Just gcd.gc_pos
332
		PD_Derive [] -> Nothing
333 334 335 336 337
		PD_Erroneous -> Nothing

instance pos ParsedSelector where pos ps = Just ps.ps_field_pos
instance pos ParsedConstructor where pos pc = Just pc.pc_cons_pos

338
class commentIndex a :: !a -> Maybe CommentIndex
339

340
instance commentIndex (Module a)
341
where
342
	commentIndex {mod_ident} = Just (CI "Module" NoPos mod_ident.id_name)
343

344
instance commentIndex ParsedDefinition
345
where
346 347 348 349 350
	commentIndex pd = case pd of
		PD_Function pos id is_infix args rhs kind -> Just (CI "PD_Function" pos id.id_name)
		PD_TypeSpec pos id prio type specials -> Just (CI "PD_TypeSpec" pos id.id_name)
		PD_Class cd pds -> Just (CI "PD_Class" cd.class_pos cd.class_ident.id_name)
		PD_Type ptd -> Just (CI "PD_Type" ptd.td_pos ptd.td_ident.id_name)
351
		PD_Generic gd -> Just (CI "PD_Generic" gd.gen_pos gd.gen_ident.id_name)
352 353
		_ -> Nothing

354 355 356 357
instance commentIndex ParsedSelector
where commentIndex ps = Just (CI "ParsedSelector" ps.ps_field_pos ps.ps_field_ident.id_name)
instance commentIndex ParsedConstructor
where commentIndex pc = Just (CI "ParsedConstructor" pc.pc_cons_pos pc.pc_cons_ident.id_name)