Merge branch 'remove-compiler-patches'

Clean/Parse.dcl

+definition module Clean.Parse
+
+/**
+ * A small wrapper around the parser of the Clean compiler.
+ * You will need to have the source of the Clean compiler available in your path.
+ */
+
+from Data.Error import :: MaybeError
+from Data.Maybe import :: Maybe
+from System.FilePath import :: FilePath
+
+from hashtable import :: HashTable
+from Heap import :: Heap
+from syntax import :: Module, :: ParsedDefinition, :: ParsedModule
+
+/**
+ * Parse a Clean module.
+ *
+ * @param The path to the file to parse
+ * @result
+ *   The parsed module and the corresponding hash table.
+ *   When the result is an {{`Error`}}, there is a descriptive error message.
+ */
+readModule :: !FilePath !*World -> *(!MaybeError String (ParsedModule, HashTable), !*World)

Clean/Parse.icl

+implementation module Clean.Parse
+
+// NOTE: be VERY restrictive with adding imports here, because this may break
+// the module when the compiler changes.
+
+import StdFile
+
+import Data.Error
+import Data.Maybe
+import System.File
+import System.FilePath
+from Text import class Text(endsWith), instance Text String
+
+from hashtable import :: BoxedIdent{boxed_ident}, :: HashTable,
+	:: IdentClass(IC_Module), :: QualifiedIdents(NoQualifiedIdents),
+	putIdentInHashTable, set_hte_mark, newHashTable
+from parse import wantModule
+import syntax
+
+readModule :: !FilePath !*World -> *(!MaybeError String (ParsedModule, HashTable), !*World)
+readModule filename w
+# (s,w) = readFile filename w
+| isError s = (Error (toString (fromError s)), w)
+# modname = getModuleName (fromString (fromOk s))
+# modname = fromMaybe (takeFileName (dropExtension filename)) modname
+# ht = newHashTable newHeap
+# ht = set_hte_mark (if icl 1 0) ht
+# (ok,f,w) = fopen filename FReadText w
+| not ok = (Error ("Couldn't open " +++ filename), w)
+# (mod_id, ht) = putIdentInHashTable modname (IC_Module NoQualifiedIdents) ht
+# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos True ht stderr) w
+# (ok,w) = fclose f w
+| not ok = (Error ("Couldn't close " +++ filename), w)
+= (Ok (pm, ht), w)
+where
+	icl = endsWith "icl" filename
+
+	wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
+		-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
+	wantModule` f s b1 i p b2 ht io fs
+	# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
+	= ((b1,b2,pm,ht,f),fs)
+
+// A reasonably accurate simple scanner to get the module name from the file
+
+getModuleName :: ![Char] -> Maybe String
+getModuleName ['definition':c:cs]     | isSpace c = justModule cs
+getModuleName ['implementation':c:cs] | isSpace c = justModule cs
+getModuleName ['system':c:cs]         | isSpace c = justModule cs
+getModuleName [c:cs]                  | isSpace c = getModuleName cs
+getModuleName ['//':cs]                           = getModuleName (dropWhile ((<>) '\n') cs)
+getModuleName ['/*':cs]                           = getModuleName (skipMultiLineComment cs)
+getModuleName cs                                  = justModule cs
+
+justModule :: ![Char] -> Maybe String
+justModule ['module':c:cs] | isSpace c = justModuleName cs
+justModule [c:cs]          | isSpace c = justModule cs
+justModule ['//':cs]                   = justModule (dropWhile ((<>) '\n') cs)
+justModule ['/*':cs]                   = justModule (skipMultiLineComment cs)
+justModule _                           = Nothing
+
+justModuleName :: ![Char] -> Maybe String
+justModuleName cs
+# (_,cs) = span isSpace cs
+# (name,_) = span (\c -> c <> '/' && c <> ';' && not (isSpace c)) cs
+= case name of
+	[] -> Nothing
+	_  -> Just (toString name)
+
+skipMultiLineComment :: ![Char] -> [Char]
+skipMultiLineComment ['*/':cs] = cs
+skipMultiLineComment ['/*':cs] = skipMultiLineComment (skipMultiLineComment cs)
+skipMultiLineComment [c:cs] = skipMultiLineComment cs
+skipMultiLineComment [] = []

Clean/Parse/Comments.dcl

+definition module Clean.Parse.Comments
+
+/**
+ * This module can combine the AST of the Clean compiler (which can be parsed
+ * using {{`Clean.Parse`}} with comments scanned by {{`Clean.ScanComments`}}.
+ */
+
+from StdFile import class FileSystem
+
+from Data.Error import :: MaybeError
+from Data.Maybe import :: Maybe
+from System.File import :: FileError
+from System.FilePath import :: FilePath
+
+from syntax import :: Ident, :: Module, :: ParsedDefinition, :: ParsedModule
+
+:: CleanComment =
+	{ line      :: !Int
+	, column    :: !Int
+	, level     :: !Maybe Int
+	, content   :: !String
+	, multiline :: !Bool
+	}
+
+scanComments :: !FilePath !*env -> *(!MaybeError FileError [CleanComment], !*env) | FileSystem env
+scanCommentsFile :: !*File -> *(!MaybeError FileError [CleanComment], !*File)
+
+:: CollectedComments
+
+emptyCollectedComments :: CollectedComments
+getComment :: !Ident !CollectedComments -> Maybe String
+collectComments :: ![CleanComment] !ParsedModule -> CollectedComments

Clean/Parse/Comments.icl

+implementation module Clean.Parse.Comments
+
+import StdArray
+import StdBool
+import StdChar
+import StdClass
+import StdFunc
+import StdInt
+import StdList
+import StdString
+import StdTuple
+
+import Control.Monad
+import Data.Error
+import Data.Functor
+from Data.Map import :: Map
+import qualified Data.Map as M
+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,
+	:: CollectedDefinitions,
+	:: ComponentNrAndIndex,
+	:: ConsDef,
+	:: Declaration,
+	:: FileName,
+	:: FunctionOrMacroIndex,
+	:: FunctName,
+	:: FunKind,
+	:: FunSpecials,
+	:: GenericDef{gen_pos},
+	:: 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,
+	:: ParsedSelector{ps_field_pos,ps_selector_ident},
+	:: 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
+	, comment_idxs  :: ![(!Int,!Int,!Int)] // line, col, idx
+	, 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)
+# [c1,c2:_] = [ss.input.[i] \\ i <- [idx..]]
+| c1 == '\r'
+	= scan (advance ss)
+| c1 == '\n'
+	= scan {ss & idx=idx+1, ln=ss.ln+1, col=0}
+| c1 == '/' && c2 == '/' && 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)
+| c1 == '/' && c2 == '*'
+	= 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]
+		}
+| c1 == '*' && c2 == '/' && 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)
+| c1 == '['
+	= scan (skip_list_literal (advance ss))
+| c1 == '"'
+	= scan (skip_string_literal '"' (advance ss))
+| otherwise
+	= scan (advance ss)
+
+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]
+| c == term = ss
+| 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
+
+:: CollectedComments :== Map (!Int, !String) CleanComment
+
+getCC :== 'M'.get o toCCIndex
+putCC k v coll :== case index k of
+	Nothing -> coll
+	Just k  -> 'M'.put (toCCIndex k) v coll
+
+toCCIndex :: !(!STE_Kind,!String) -> (!Int, !String)
+toCCIndex (stek,name) = (toint stek, name)
+where
+	toint :: !STE_Kind -> Int
+	toint kind = case kind of
+		STE_FunctionOrMacro _ -> 0
+		STE_DclMacroOrLocalMacroFunction _ -> 1
+		STE_Type -> 2
+		STE_Constructor -> 3
+		STE_Selector _ -> 4
+		STE_Field _ -> 5
+		STE_Class -> 6
+		STE_Member -> 7
+		STE_Generic _ -> 8
+		STE_GenericCase -> 9
+		STE_GenericDeriveClass -> 10
+		STE_Instance -> 11
+		STE_Variable _ -> 12
+		STE_TypeVariable _ -> 13
+		STE_FunDepTypeVariable _ -> 14
+		STE_TypeAttribute _ -> 15
+		STE_BoundTypeVariable _ -> 16
+		STE_Imported _ _ -> 17
+		STE_DclFunction -> 18
+		STE_Module _ -> 19
+		STE_ClosedModule -> 20
+		STE_ModuleQualifiedImports _ -> 21
+		STE_Empty -> 22
+		STE_DictType _ -> 23
+		STE_DictCons _ -> 24
+		STE_DictField _ -> 25
+		STE_Called _ -> 26
+		STE_ExplImpSymbol _ -> 27
+		STE_ExplImpComponentNrs _ -> 28
+		STE_BelongingSymbol _ -> 29
+		STE_ExplImpSymbolNotImported _ _ -> 30
+		STE_ImportedQualified _ _ -> 31
+		STE_Hidden _ _ -> 32
+		STE_UsedType _ _ -> 33
+		STE_UsedQualifiedType _ _ _ -> 34
+		STE_BelongingSymbolExported -> 35
+		STE_BelongingSymbolForExportedSymbol -> 36
+		STE_TypeExtension -> 37
+
+emptyCollectedComments :: CollectedComments
+emptyCollectedComments = 'M'.newMap
+
+getComment :: !Ident !CollectedComments -> Maybe String
+getComment {id_name,id_info={pointer=Ptr {ste_kind} _}} coll =
+	(\cc -> cc.content) <$> getCC (ste_kind,id_name) coll
+
+collectComments :: ![CleanComment] !ParsedModule -> CollectedComments
+collectComments comments pm
+# coll = 'M'.newMap
+# (comments,coll) = case comments of
+	[] -> ([], coll)
+	[c:cs]
+		| c.line <= 3 -> (cs, putCC pm.mod_ident c coll)
+		| otherwise   -> (comments, coll)
+# (_,_,coll) = collect comments Nothing pm.mod_defs coll
+= coll
+
+collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, index, children a
+collect cc prev [] coll = (cc, prev, coll)
+collect [] (Just prev) [pd:pds] coll = ([], Nothing, putCC pd prev coll)
+collect [] Nothing _ coll = ([], Nothing, coll)
+collect [{column,multiline=True}:cs] prev pds coll | column > 0 = collect cs prev pds 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
+	Just True -> collect cs (Just c) allpds coll
+	Just False -> case prev of
+		Nothing -> collect allcmnts Nothing pds coll
+		Just cmnt
+			# coll = putCC pd cmnt coll
+			# (allcmnts,prev,coll) = recurse allcmnts Nothing (children pd) coll
+			-> collect allcmnts prev pds coll
+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
+
+:: Children = E.t: Children ![t] & pos, index, children t
+
+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])
+
+(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos a
+(canBelongTo) {line,multiline} p = pos p >>= \p -> case p of
+	FunPos _ ln _ -> Just (if multiline (>) (>=) ln line)
+	LinePos _ ln  -> Just (if multiline (>) (>=) ln line)
+	_             -> Nothing
+
+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
+		PD_Import [pi:_] -> Just pi.import_file_position
+		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
+		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
+
+class index a :: !a -> Maybe (!STE_Kind,!String)
+
+instance index Ident
+where
+	index {id_name,id_info={pointer=Ptr {ste_kind} _}} = Just (ste_kind,id_name)
+
+instance index ParsedDefinition
+where
+	index pd = case pd of
+		PD_Function pos id is_infix args rhs kind -> index id
+		PD_TypeSpec pos id prio type specials -> index id
+		PD_Class cd pds -> index cd.class_ident
+		PD_Type ptd -> index ptd.td_ident
+		_ -> Nothing
+
+instance index ParsedSelector where index ps = index ps.ps_selector_ident
+instance index ParsedConstructor where index pc = index pc.pc_cons_ident

Cloogle/DB/Factory.icl

@@ -34,20 +34,16 @@ from Text import class Text(concat,indexOf,replaceSubString,startsWith),
 	instance Text String, <+
 
 from compile import :: DclCache{hash_table}, empty_cache
-from hashtable import :: BoxedIdent{boxed_ident}, :: HashTable{hte_symbol_heap},
-	:: IdentClass(IC_Module), :: QualifiedIdents(NoQualifiedIdents),
-	putIdentInHashTable, set_hte_mark, newHashTable
 from Heap import :: Heap, newHeap, sreadPtr
-from parse import wantModule
 from predef import init_identifiers
 from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
 	:: FileName, :: FunctName, :: FunKind(FK_Macro), :: FunSpecials, :: GCF,
 	:: GenericCaseDef{gc_gcf,gc_pos,gc_type}, :: GenericCaseFunctions(GCF,GCFC),
 	:: GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
 	:: Ident{id_name,id_info}, :: LineNr, :: Module{mod_defs,mod_ident},
-	:: Optional(Yes,No), :: SymbolPtr, :: Ptr, :: SymbolTableEntry{ste_doc},
+	:: Optional(Yes,No), :: SymbolPtr, :: Ptr, :: SymbolTableEntry,
 	:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,
-		PD_Instances,PD_Type,PD_TypeSpec,PD_Documentation,PD_GenericCase,
+		PD_Instances,PD_Type,PD_TypeSpec,PD_GenericCase,
 		PD_NodeDef,PD_Import),
 	:: ParsedExpr(PE_Ident,PE_List),
 	:: ParsedInstance{pi_ident,pi_pos,pi_types},
@@ -57,9 +53,8 @@ from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
 		AbstractTypeSpec,NewTypeCons,MoreConses),
 	:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
 	:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
-	:: ParsedConstructor{pc_doc}, :: ParsedSelector{ps_doc},
-	:: ParsedImport, :: Import{import_module},
-	:: DocType, :: OptionalDoc
+	:: ParsedConstructor{pc_cons_ident}, :: ParsedSelector{ps_selector_ident},
+	:: ParsedImport, :: Import{import_module}
 
 import Clean.PrettyPrint
 
@@ -82,6 +77,8 @@ from Clean.Doc import :: ModuleDoc, :: FunctionDoc{vars,description}, :: ClassDo
 	traceParseError, traceParseWarnings,
 	constructorToFunctionDoc, functionToClassMemberDoc, addClassMemberDoc
 import Clean.Idents
+import Clean.Parse
+import Clean.Parse.Comments
 
 from Cloogle.API import :: FunctionKind(..), instance == FunctionKind
 import qualified Cloogle.DB as CDB
@@ -471,22 +468,31 @@ findModuleContents :: !Bool !String !*World
 	    , !*World
 	    )
 findModuleContents include_locals path w
-#! (dcl,dcl_symbols,w) = readModule False w
-#! dcl = case dcl of Left _ -> []; Right dcl -> dcl.mod_defs
-#! (icl,icl_symbols,w) = readModule True w
+#! (dclcomments,w) = scanComments (path +++ ".dcl") w
+#! (dcl,w) = readModule (path +++ ".dcl") w
+#! (dclmod,dcl,documentation) = case dcl of
+	Error _ -> (zero, [], emptyCollectedComments)
+	Ok (dcl,_) -> case dclcomments of
<