implementation module CleanDocParser import StdEnv import System.File import Text import Data.Maybe import Data.Error import Text.ParserCombinators import System._Unsafe import GenEq from general import :: Optional(..) from checksupport import ::Heaps from Heap import ::Heap, newHeap, ::Ptr from hashtable import ::HashTable, newHashTable, set_hte_mark from predef import init_identifiers from scanner import ::Token(..), ::Priority(..), ::Assoc(..), ::ScanState(..), ::RScanState(..), ::Buffer(..), ::LongToken(..), ::FilePosition(..), ::ScanInput(..), ::Input(..), ::SBuffer(..), ::InputStream(..), setUseLayout, ::ScanContext(..), GeneralContext, class nextToken(..), instance nextToken ScanState, class tokenBack(..), instance tokenBack ScanState, setUseUnderscoreIdents, instance == Token from syntax import ::SymbolTable, ::SymbolTableEntry, ::SymbolPtr, ::ModuleKind(..), ::ParsedDefinition, ::ParsedExpr(..), ::ArrayKind, ::TypeKind, ::Ident(..), ::Env, ::FieldNameOrQualifiedFieldName, ::Bind, ::DynamicType, ::CodeBinding, ::Global, ::FieldSymbol, ::Sequence, ::Qualifier, ::LocalDefs, ::CaseAlt, ::ParsedSelection, ::ParsedSelectorKind, ::ElemAssignment, ::FieldAssignment, ::OptionalRecordName, ::Position, ::BoundExpr, ::Type(TE), ::BasicValue from parse import ::ParseErrorAdmin(..), ::ParseState(..), ::ParseContext(..), SetGlobalContext, wantDefinitions, wantExpression, wantType, PS_SupportGenericsMask parseModule :: !String !Bool *File -> ([ParsedDefinition], *File) parseModule input iclmodule error # hash_table = newHashTable newHeap # scanState = stringScanner input # (ok, moduleKind, moduleName, scanState) = try_module_header iclmodule scanState | not ok = ([], error) # hash_table = set_hte_mark (if iclmodule 1 0) hash_table # scanState = setUseLayout True scanState # (_, scanState) = nextToken GeneralContext scanState # parseContext = SetGlobalContext iclmodule # parseState = { ps_scanState = scanState , ps_error = { pea_file = error, pea_ok = True } , ps_flags = PS_SupportGenericsMask , ps_hash_table = hash_table } # (defs,parseState) = wantDefinitions parseContext parseState = (defs, parseState.ps_error.pea_file) try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState) try_module_header is_icl_mod scanState # (token, scanState) = nextToken GeneralContext scanState | is_icl_mod && token == ImpModuleToken = try_module_token MK_Module scanState | token == DefModuleToken = try_module_token MK_Module scanState try_module_token :: !ModuleKind !ScanState -> (!Bool,!ModuleKind,!String,!ScanState) try_module_token mod_type scanState # (token, scanState) = nextToken GeneralContext scanState | token == ModuleToken # (token, scanState) = nextToken GeneralContext scanState = try_module_name token mod_type scanState = (False, mod_type, "", tokenBack scanState) try_module_name :: Token !ModuleKind !ScanState -> (Bool, !ModuleKind, !String, !ScanState) try_module_name (IdentToken name) mod_type scanState = (True, mod_type, name, scanState) try_module_name (UnderscoreIdentToken name) mod_type scanState = (True, mod_type, name, setUseUnderscoreIdents True scanState) try_module_name token mod_type scanState = (False, mod_type, "", tokenBack scanState) stringScanner :: !String -> ScanState stringScanner input # lines = split "\n" input //TODO: dont use Text.split # inputStream = foldr (\a b -> OldLine 0 (a +++ "\n") b) EmptyStream lines = ScanState { ss_input = Input { inp_stream = inputStream , inp_filename = "" , inp_pos = {fp_line = 1, fp_col = 0} , inp_tabsize = 4 } , ss_offsides = [(1,False)] // to generate offsides between global definitions , ss_scanOptions = 0 , ss_tokenBuffer = Buffer0 } parseUnsafe :: !String (*ParseState -> (a, *ParseState)) (a -> Bool) -> Maybe a parseUnsafe input parser isValid = accUnsafe parseUnsafe` where parseUnsafe` world # errorFilename = "errors.txt" # (ok, file, world) = fopen errorFilename FWriteText world | not ok = (Nothing, world) # (exp, file) = parse input parser file # (ok,world) = fclose file world | not ok = (Nothing, world) # (res,world) = deleteFile errorFilename world | isError res = (Nothing, world) | not (isValid exp) = (Nothing, world) = (Just exp, world) parse :: !String (*ParseState -> (a, *ParseState)) *File -> (a, *File) parse input parser error # hash_table = newHashTable newHeap # scanState = stringScanner input # hash_table = set_hte_mark 1 hash_table # parseState = { ps_scanState = scanState , ps_error = { pea_file = error, pea_ok = True } , ps_flags = PS_SupportGenericsMask , ps_hash_table = hash_table } # (result,parseState) = parser parseState = (result,parseState.ps_error.pea_file) parseExpressionUnsafe :: !String -> Maybe ParsedExpr parseExpressionUnsafe input = parseUnsafe input (wantExpression False) (\p -> case p of PE_Empty = False; _ = True) parseTypeUnsafe :: !String -> Maybe Type parseTypeUnsafe input = parseUnsafe input wantType (\t -> case t of TE = False; _ = True) //Lexer for documentation blocks :: DocToken = ParamDocToken | DefaultDocToken | ThrowsDocToken | ReturnDocToken | TitleDocToken | IconDocToken | ShapeDocToken | ParallelSplitDocToken | ParallelDocToken | VisibleDocToken | GinDocToken | ColonDocToken | TextDocToken !String | NewLineDocToken derive gEq DocToken instance == DocToken where (==) a b = a === b isText :: !DocToken -> Bool isText (TextDocToken _) = True isText _ = False :: LexFunction :== String Int -> Maybe (DocToken, Int) lex :: !String -> [DocToken] lex input = (lex` 0 0 lexFunctions) where lexFunctions :: [LexFunction] lexFunctions = [ lexFixed "@param" ParamDocToken , lexFixed "@default" DefaultDocToken , lexFixed "@throws" ThrowsDocToken , lexFixed "@return" ReturnDocToken , lexFixed "@gin-title" TitleDocToken , lexFixed "@gin-icon" IconDocToken , lexFixed "@gin-shape" ShapeDocToken , lexFixed "@gin-parallel" ParallelDocToken , lexFixed "@gin-visible" VisibleDocToken , lexFixed "@gin" GinDocToken , lexFixed ":" ColonDocToken , lexFixed "\n*" NewLineDocToken ] lex` :: !Int !Int ![LexFunction] -> [DocToken] lex` offset start _ | offset >= size input = if (offset <> start) [TextDocToken (trim (input % (start, offset - 1)))] [] lex` offset start [] = lex` (offset + 1) start lexFunctions lex` offset start [f:fs] # text = if (offset <> start) [TextDocToken (trim (input % (start, offset - 1)))] [] = case f input offset of Just (NewLineDocToken,offset) = text ++ lex` offset offset lexFunctions Just (token,offset) = text ++ [token : lex` offset offset lexFunctions] Nothing = lex` offset start fs //Lex token of fixed size lexFixed chars token input offset | input % (offset,offset + (size chars) - 1) == chars = Just (token, offset + size chars) = Nothing parseWith :: (Parser DocToken a) !String -> MaybeErrorString a parseWith parser str # doc = parser (lex str) | isEmpty doc = Error "Parse error" = Ok (snd (hd doc)) //Parser for module comments :: ModuleComment = { description :: !Maybe String } emptyModuleComment :: ModuleComment emptyModuleComment = { ModuleComment | description = Nothing } parseModuleComment :: !String -> MaybeErrorString ModuleComment parseModuleComment str = parseWith pModuleComment str pModuleComment :: Parser DocToken ModuleComment pModuleComment = begin1 pModuleComment` where pModuleComment` = pText <&> \description -> yield { ModuleComment | emptyModuleComment & description = Just description } //Parser for function comments emptyFunctionComment :: FunctionComment emptyFunctionComment = { FunctionComment | description = Nothing , params = [] , return = Nothing , throws = [] , gin = True , title = Nothing , icon = Nothing , parallel = False , shape = Nothing } parseFunctionComment :: !String -> MaybeErrorString FunctionComment parseFunctionComment str = parseWith pFunctionComment str pFunctionComment :: Parser DocToken FunctionComment pFunctionComment = begin1 pFunctionComment` where pFunctionComment` = pDescription <&> \description -> (<*> (pParam pReturn pThrows pGin pTitle pIcon pShape pParallel)) <&> \args -> yield ((seq args) (description emptyFunctionComment)) pDescription = pText <&> \description -> yield (\doc -> { FunctionComment | doc & description = Just description }) pParam = symbol ParamDocToken &> pText <&> \title -> symbol ColonDocToken &> pText <&> \description -> ( (symbol DefaultDocToken &> pText) Just Nothing) <&> \defaultValue -> ((symbol VisibleDocToken &> pBool) yield True) <&> \visible -> yield (\doc -> { FunctionComment | doc & params = doc.params ++ [{ ParamComment | name = makeIdent title , title = Just title , description = Just description , defaultValue = defaultValue , visible = visible }] }) where makeIdent s = replaceSubString " " "_" (toLowerCase s) pReturn = symbol ReturnDocToken &> pText <&> \return -> yield (\doc -> { FunctionComment | doc & return = Just return }) pThrows = symbol ThrowsDocToken &> pText <&> \throws -> yield (\doc -> { FunctionComment | doc & throws = doc.throws ++ [throws]}) pGin = symbol GinDocToken &> pBool <&> \gin -> yield (\doc -> { FunctionComment | doc & gin = gin }) pTitle = symbol TitleDocToken &> pText <&> \title -> yield (\doc -> { FunctionComment | doc & title = Just title }) pIcon = symbol IconDocToken &> pText <&> \icon -> yield (\doc -> { FunctionComment | doc & icon = Just icon }) pShape = symbol ShapeDocToken &> pText <&> \shape -> yield (\doc -> { FunctionComment | doc & shape = Just shape }) pParallel = symbol ParallelDocToken &> pBool <&> \parallel -> yield (\doc -> { FunctionComment | doc & parallel = parallel }) pBool = pText <&> \value -> yield (toLowerCase value == "true") pText = satisfy isText <@ \(TextDocToken t) -> t //Parser for Type comments :: TypeComment = { description :: !Maybe String } emptyTypeComment :: TypeComment emptyTypeComment = { TypeComment | description = Nothing } parseTypeComment :: !String -> MaybeErrorString TypeComment parseTypeComment str = parseWith pTypeComment str pTypeComment :: Parser DocToken TypeComment pTypeComment = begin1 pTypeComment` where pTypeComment` = pText <&> \description -> yield { TypeComment | emptyTypeComment & description = Just description } allTokens :: ScanState -> [Token] allTokens sState # (token, sState) = nextToken GeneralContext sState = case token of EndOfFileToken = [EndOfFileToken] t = [t : allTokens sState] //Start = allTokens (stringScanner "a")