Verified Commit ac2c958c authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'remove-compiler-patches'

parents 238392d4 f9383425
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)
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 [] = []
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
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
......@@ -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
Error _ -> (zero, dcl.mod_defs, emptyCollectedComments)
Ok comments -> let coll = collectComments comments dcl in
( {zero & me_documentation=docParseResultToMaybe (const True) =<< parseDoc <$> getComment dcl.mod_ident coll}
, dcl.mod_defs
, coll
)
#! (icl,w) = readModule (path +++ ".icl") w
#! (icl,modname) = case icl of
Left _ -> ([], "")
Right icl -> (icl.mod_defs, icl.mod_ident.id_name)
Error _ -> ([], "")
Ok (icl,syms) -> (icl.mod_defs, icl.mod_ident.id_name)
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- dcl ++ icl, i <- is]
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
( combine cmpLocFst3 joinLocFstIds pd_typespecs dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFstIds pd_rewriterules dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFstIds pd_generics dcl dcl_symbols icl icl_symbols
, combine cmpLocFst joinTypeDefs pd_types dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFst3 pd_classes dcl dcl_symbols icl icl_symbols
, combine cmpInsts joinInsts pd_instances dcl dcl_symbols icl icl_symbols
( combine cmpLocFst3 joinLocFstIds pd_typespecs dcl documentation icl
, combine cmpLocFst3 joinLocFstIds pd_rewriterules dcl documentation icl
, combine cmpLocFst3 joinLocFstIds pd_generics dcl documentation icl
, combine cmpLocFst joinTypeDefs pd_types dcl documentation icl
, combine cmpLocFst3 joinLocFst3 pd_classes dcl documentation icl
, combine cmpInsts joinInsts pd_instances dcl documentation icl
, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl dcl_symbols icl icl_symbols
, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl documentation icl
)
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
if include_locals
......@@ -501,17 +507,17 @@ findModuleContents include_locals path w
, filter (hasDcl o (\(_,_,_,x)->x)) clsderivs
) with hasDcl loc = isJust loc.dcl_line
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.LocationInModule.name == fromJust r.LocationInModule.name) functions) rules
= (functions,rules,generics,</