Parse documentation; index macro/generic/normal function documentation

Doc.dcl

+definition module Doc
+
+from Data.Either import :: Either
+from Data.Maybe import :: Maybe
+
+:: Documentation
+	= ModuleDoc (Maybe Description)
+	| FunctionDoc (Maybe Description) [ParamDoc] [VarDoc] (Maybe ResultDoc)
+	| ClassDoc (Maybe Description) [VarDoc] [ClassMemberDoc]
+	| TypeDoc (Maybe Description) [VarDoc] (Maybe TypeRhsDoc)
+	| ConstructorDoc (Maybe Description) [ParamDoc]
+
+:: ClassMemberDoc
+	= ClassMemberDoc (Maybe Description) [ParamDoc] (Maybe ResultDoc)
+
+:: TypeRhsDoc
+	= ADTDoc [Documentation] // Only uses ConstructorDoc
+	| RecordDoc [RecordFieldDoc]
+	| SynonymDoc (Maybe Description)
+
+:: ParamDoc :== Description
+:: VarDoc :== Description
+:: ResultDoc :== Description
+:: RecordFieldDoc :== Description
+:: Description :== String
+
+:: ParseError
+	= MissingAsterisk     // At least one line did not start with a *
+	| IllegalState String // Incorrect usage of this module
+
+:: ParseWarning
+	= UnknownField String // Unknown @-field
+	| IllegalField String // This @-field is not allowed in this docblock
+	| NoDescription       // The main description is missing
+	| UsedReturn          // Used @return instead of @result
+	| SkippedLine String  // Skipped an unparseable line
+
+getDocDescription :: Documentation -> Maybe Description
+getParamDocs :: Documentation -> [ParamDoc]
+getVarDocs :: Documentation -> [ParamDoc]
+getResultDoc :: Documentation -> Maybe String
+
+parseModuleDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseFunctionDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseClassDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseAbstractTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseSynonymTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseADTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseRecordTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+
+parseConstructorDoc :: String Documentation
+	-> Either ParseError (Documentation, [ParseWarning])
+	// Second argument should be a TypeDoc with an ADTDoc
+
+traceParseWarnings :: [ParseWarning] !a -> a
+traceParseError :: ParseError !a -> a

Doc.icl

+implementation module Doc
+
+import StdChar
+import StdDebug
+from StdFunc import flip, o, twice
+import StdList
+import StdMisc
+import StdString
+
+import Control.Monad
+import Data.Either
+from Data.Func import $
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Data.Tuple
+
+:: DocField
+	= Param String
+	| Var String
+	| Result String
+	| Field String
+	| Representation String
+
+:: FieldUpdateFunction :==
+	DocField Documentation -> Either ParseError (Documentation, [ParseWarning])
+
+fieldName :: DocField -> String
+fieldName (Param _)          = "param"
+fieldName (Var _)            = "var"
+fieldName (Result _)         = "result"
+fieldName (Field _)          = "field"
+fieldName (Representation _) = "representation"
+
+getDocDescription :: Documentation -> Maybe Description
+getDocDescription (ModuleDoc d)         = d
+getDocDescription (FunctionDoc d _ _ _) = d
+getDocDescription (ClassDoc d _ _)      = d
+getDocDescription (TypeDoc d _ _)       = d
+getDocDescription (ConstructorDoc d _)  = d
+
+getParamDocs :: Documentation -> [ParamDoc]
+getParamDocs (FunctionDoc _ ps _ _) = ps
+getParamDocs (ConstructorDoc _ ps)  = ps
+getParamDocs _                      = []
+
+getVarDocs :: Documentation -> [ParamDoc]
+getVarDocs (FunctionDoc _ _ vs _) = vs
+getVarDocs (ClassDoc _ vs _)      = vs
+getVarDocs (TypeDoc _ vs _)       = vs
+getVarDocs _                      = []
+
+getResultDoc :: Documentation -> Maybe String
+getResultDoc (FunctionDoc _ _ _ r) = r
+getResultDoc _                     = Nothing
+
+parseModuleDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseModuleDoc = parseDocBlock $ ModuleDoc Nothing
+
+parseFunctionDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseFunctionDoc = parseDocBlock $ FunctionDoc Nothing [] [] Nothing
+
+parseClassDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseClassDoc = parseDocBlock $ ClassDoc Nothing [] []
+
+parseAbstractTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseAbstractTypeDoc = parseDocBlock $ TypeDoc Nothing [] Nothing
+
+parseSynonymTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseSynonymTypeDoc = parseDocBlock $ TypeDoc Nothing [] $ Just $ SynonymDoc Nothing
+
+parseADTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseADTypeDoc = parseDocBlock $ TypeDoc Nothing [] $ Just $ ADTDoc []
+
+parseRecordTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+parseRecordTypeDoc = parseDocBlock $ TypeDoc Nothing [] $ Just $ RecordDoc []
+
+parseConstructorDoc :: String Documentation
+	-> Either ParseError (Documentation, [ParseWarning])
+parseConstructorDoc s (TypeDoc d vs (Just (ADTDoc cs)))
+	= appFst (TypeDoc d vs o Just o ADTDoc o (\c -> [c:cs]))
+		<$> parseDocBlock (ConstructorDoc Nothing []) s
+
+updateDesc :: [[Char]] Documentation -> Documentation
+updateDesc desc doc = case doc of
+	FunctionDoc _ ps vs r = FunctionDoc desc` ps vs r
+	ModuleDoc _           = ModuleDoc desc`
+	ClassDoc _ vs cms     = ClassDoc desc` vs cms
+	TypeDoc _ vs rhs      = TypeDoc desc` vs rhs
+where
+	desc` = Just $ toString $ flatten $ intersperse ['\n'] desc
+
+parseDocBlock :: Documentation String
+	-> Either ParseError (Documentation, [ParseWarning])
+parseDocBlock doc block = prepareString block >>= parsef
+where
+	parsef :: [[Char]] -> Either ParseError (Documentation, [ParseWarning])
+	parsef [] = Right (doc, [])
+	parsef lines = case span ((<>) '@' o hd) lines of
+		([],   rest) = appSnd (\ws -> [NoDescription:ws]) <$> parseFields doc rest
+		(desc, rest) = appFst (updateDesc desc) <$> parseFields doc rest
+
+	parseFields :: Documentation [[Char]]
+		-> Either ParseError (Documentation, [ParseWarning])
+	parseFields org []
+		= Right (org, [])
+	parseFields org [['@':'p':'a':'r':'a':'m':desc]:rest]
+		= concatWarnings upd (Param $ prepField desc) =<< parseFields org rest
+	parseFields org [['@':'r':'e':'s':'u':'l':'t':desc]:rest]
+		= concatWarnings upd (Result $ prepField desc) =<< parseFields org rest
+	parseFields org [['@':'r':'e':'t':'u':'r':'n':desc]:rest]
+		= appSnd ((++) [UsedReturn]) <$>
+			(concatWarnings upd (Result $ prepField desc) =<< parseFields org rest)
+	parseFields org [['@':'v':'a':'r':desc]:rest]
+		= concatWarnings upd (Var $ prepField desc) =<< parseFields org rest
+	parseFields org [['@':'f':'i':'e':'l':'d':desc]:rest]
+		= concatWarnings upd (Field $ prepField desc) =<< parseFields org rest
+	parseFields org [['@':'r':'e':'p':'r':'e':'s':'e':'n':'t':'a':'t':'i':'o':'n':desc]:rest]
+		= concatWarnings upd (Representation $ prepField desc) =<< parseFields org rest
+	parseFields org [['@':line]:rest]
+		= appSnd ((++) [UnknownField $ toString $ takeWhile (not o isSpace) line])
+			<$> parseFields org rest
+	parseFields org [line:rest]
+		= appSnd ((++) [SkippedLine $ toString line]) <$> parseFields org rest
+
+	upd :: DocField Documentation
+		-> Either ParseError (Documentation, [ParseWarning])
+	upd (Param d) (FunctionDoc t ps vs r) = Right (FunctionDoc t [d:ps] vs r, [])
+	upd (Result d) (FunctionDoc t ps vs _) = Right (FunctionDoc t ps vs (Just d), [])
+	upd (Var d) (FunctionDoc t ps vs r) = Right (FunctionDoc t ps [d:vs] r, [])
+	upd (Param d) (ConstructorDoc t ps) = Right (ConstructorDoc t [d:ps], [])
+	upd (Var d) (ClassDoc t vs ms) = Right (ClassDoc t [d:vs] ms, [])
+	upd (Var d) (TypeDoc t vs rhs) = Right (TypeDoc t [d:vs] rhs, [])
+	upd (Field d) (TypeDoc t vs (Just (RecordDoc fs)))
+		= Right (TypeDoc t vs $ Just $ RecordDoc [d:fs], [])
+	upd (Representation d) (TypeDoc t vs (Just (SynonymDoc _)))
+		= Right (TypeDoc t vs $ Just $ SynonymDoc $ Just d, [])
+	upd f doc = Right (doc, [IllegalField $ fieldName f])
+
+	prepField :: ([Char] -> String)
+	prepField = toString o trim
+
+	concatWarnings :: FieldUpdateFunction DocField (Documentation, [ParseWarning])
+		-> Either ParseError (Documentation, [ParseWarning])
+	concatWarnings f df (doc, ws) = appSnd ((++) ws) <$> f df doc
+
+	prepareString :: String -> Either ParseError [[Char]]
+	prepareString s
+		= filter (not o isEmpty) <$>
+			( checkAsterisks
+			$ filter (not o isEmpty)
+			$ map (twice (reverse o trim))
+			$ break '\n'
+			$ fromString s
+			)
+	where
+		checkAsterisks :: [[Char]] -> Either ParseError [[Char]]
+		checkAsterisks lines
+		| all ((==) '*' o hd) lines = Right $ map (trim o tl) lines
+		| otherwise                 = Left MissingAsterisk
+
+		break :: a -> [a] -> [[a]] | == a
+		break e = foldr f []
+		where
+			f x []     = if (x == e) []        [[x]]
+			f x [y:ys] = if (x == e) [[]:y:ys] [[x:y]:ys]
+
+	trim = dropWhile isSpace
+
+instance toString ParseWarning
+where
+	toString (UnknownField f) = "Doc warning: unknown field '" +++ f +++ "'"
+	toString (IllegalField f) = "Doc warning: illegal field '" +++ f +++ "'"
+	toString NoDescription    = "Doc warning: missing description"
+	toString UsedReturn       = "Doc warning: @return is deprecated, use @result"
+	toString (SkippedLine l)  = "Doc warning: skipped line '" +++ l +++ "'"
+
+instance toString ParseError
+where
+	toString MissingAsterisk  = "Doc error: missing leading asterisk"
+	toString (IllegalState s) = "Doc error: illegal state: " +++ s
+
+traceParseWarnings :: [ParseWarning] !a -> a
+traceParseWarnings []     x = x
+traceParseWarnings [w:ws] x
+| trace_tn w = traceParseWarnings ws x
+| otherwise  = undef
+
+traceParseError :: ParseError !a -> a
+traceParseError e x
+| trace_tn e = x
+| otherwise  = undef

Search.icl

@@ -23,6 +23,7 @@ from Text import class Text(concat,indexOf,toLowerCase,split),
 import TypeDB
 import Type
 import Cloogle
+import Doc
 
 search :: !Request !TypeDB -> [Result]
 search {unify,name,className,typeName,modules,libraries,page,include_builtins,include_core} db_org
@@ -102,6 +103,7 @@ makeModuleResult mbName (lib, mod, info)
 	    , documentation = Nothing
 	    }
 	  , { module_is_core = info.is_core
+	    , module_doc    = getDocDescription =<< info.mod_documentation
 	    }
 	  )
 
@@ -202,10 +204,12 @@ makeMacroResult mbName (Location lib mod line iclline m) mac
 	    , distance
 	        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
 	    , builtin       = Nothing
-	    , documentation = mac.macro_extras.te_documentation
+	    , documentation = getDocDescription =<<  mac.macro_extras.te_documentation
 	    }
 	  , { macro_name = m
 	    , macro_representation = mac.macro_as_string
+	    , macro_param_doc = getParamDocs <$> mac.macro_extras.te_documentation
+	    , macro_result_doc = getResultDoc =<< mac.macro_extras.te_documentation
 	    }
 	  )
 
@@ -221,7 +225,7 @@ makeFunctionResult
 	    , modul         = mod
 	    , distance      = distance
 	    , builtin       = builtin
-	    , documentation = tes.te_documentation
+	    , documentation = getDocDescription =<< tes.te_documentation
 	    }
 	  , { func     = fromJust (tes.te_representation <|>
 	                           (pure $ concat $ print False (fname,et)))
@@ -237,8 +241,11 @@ makeFunctionResult
 	    , generic_derivations
 	        = let derivs = getDerivations fname db in
 	          const (sortBy (\(a,_) (b,_) -> a < b)
-			    [(s, map loc ls) \\ (_,s,ls) <- derivs]) <$>
+	              [(s, map loc ls) \\ (_,s,ls) <- derivs]) <$>
 	          tes.te_generic_vars
+	    , param_doc = getParamDocs <$> tes.te_documentation
+	    , generic_var_doc = getVarDocs <$> tes.te_documentation
+	    , result_doc = getResultDoc =<< tes.te_documentation
 	    }
 	  )
 where

TypeDB.dcl

@@ -13,15 +13,18 @@ from GenEq import generic gEq
 from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..),
   ::ClassContext, ::ClassRestriction, ::ClassOrGeneric, ::Priority
 
+from Doc import ::Documentation
+
 :: TypeDB
 
-:: TypeExtras = { te_priority       :: Maybe Priority
-                , te_isconstructor  :: Bool
-                , te_isrecordfield  :: Bool
-                , te_generic_vars   :: Maybe [TypeVar]
-                , te_representation :: Maybe String
-                , te_documentation  :: Maybe FunctionDocumentation
-                }
+:: TypeExtras
+	= { te_priority       :: Maybe Priority
+	  , te_isconstructor  :: Bool
+	  , te_isrecordfield  :: Bool
+	  , te_generic_vars   :: Maybe [TypeVar]
+	  , te_representation :: Maybe String
+	  , te_documentation  :: Maybe Documentation
+	  }
 
 :: ExtendedType = ET Type TypeExtras
 
@@ -32,7 +35,10 @@ from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..),
 :: Location = Location Library Module LineNr LineNr Name
             | Builtin                               Name
 
-:: ModuleInfo = { is_core :: Bool }
+:: ModuleInfo
+	= { is_core :: Bool
+	  , mod_documentation :: Maybe Documentation
+	  }
 
 :: Name         :== String
 :: Library      :== String
@@ -40,8 +46,6 @@ from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..),
 :: Class        :== String
 :: LineNr       :== Maybe Int
 
-:: FunctionDocumentation :== String
-
 instance zero TypeDB
 instance zero TypeExtras
 instance zero ModuleInfo

TypeDB.icl

@@ -19,6 +19,8 @@ import GenLexOrd
 // CleanTypeUnifier
 import Type
 
+import Doc
+
 :: TypeDB
 	= { // Base maps
 	    functionmap  :: Map Location ExtendedType
@@ -40,13 +42,14 @@ printersperse ia a bs = intercalate (print False a) (map (print ia) bs)
 (--) a b = print False a ++ print False b
 
 derive gEq ClassOrGeneric, Location, Type, TypeExtras, Priority,
-	ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor, Kind, Macro
+	ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor, Kind, Macro,
+	Documentation, TypeRhsDoc, ClassMemberDoc
 derive JSONEncode ClassOrGeneric, Location, Type, TypeDB, TypeExtras,
 	Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor,
-	Kind, Macro, ModuleInfo
+	Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc
 derive JSONDecode ClassOrGeneric, Location, Type, TypeDB, TypeExtras,
 	Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor,
-	Kind, Macro, ModuleInfo
+	Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc
 
 instance zero TypeDB
 where
@@ -82,7 +85,8 @@ where
 	       , te_documentation  = Nothing
 	       }
 
-instance zero ModuleInfo where zero = {is_core = False}
+instance zero ModuleInfo
+where zero = {is_core = False, mod_documentation=Nothing}
 
 instance print TypeExtras
 where

TypeDBFactory.icl

@@ -48,10 +48,11 @@ from Type import instance == Type,
 	class print(print), instance print Type, instance print Priority
 import qualified TypeDB as DB
 from TypeDB import :: Macro{macro_as_string,macro_extras},
-	:: Location(Location), filterLocations,
-	:: ModuleInfo{is_core}, :: FunctionDocumentation,
+	:: Location(Location), filterLocations, :: ModuleInfo{is_core},
 	:: TypeExtras{te_generic_vars,te_isconstructor,te_isrecordfield,te_priority,te_representation,te_documentation},
 	instance zero TypeExtras, instance zero ModuleInfo
+from Doc import :: Documentation, :: ParseWarning(UsedReturn), :: ParseError,
+	parseFunctionDoc, traceParseError, traceParseWarnings
 
 //             Exclude   Root    Library        Check for core       Base module
 findModules :: ![String] !String !'DB'.Library ('DB'.Module -> Bool) !String !*World
@@ -94,7 +95,7 @@ getModuleTypes root mod lib iscore db w
 # db  = 'DB'.putTypes typedefs db
 # db  = 'DB'.putFunctions (flatten $ map constructor_functions typedefs) db
 # db  = 'DB'.putFunctions (flatten $ map record_functions typedefs) db
-# db  = 'DB'.putFunctions (pd_generics lib modname dcl.mod_defs icl) db
+# db  = 'DB'.putFunctions (pd_generics lib modname dcl.mod_defs icl symbols) db
 # db  = 'DB'.putDerivationss (pd_derivations lib modname dcl.mod_defs) db
 # db  = 'DB'.putMacros (pd_macros lib modname dcl.mod_defs symbols) db
 # db  = 'DB'.putModule lib modname {zero & is_core=iscore} db
@@ -112,7 +113,11 @@ where
 	pd_macros lib mod dcl st
 		= [( 'DB'.Location lib mod (toLine pos) Nothing id.id_name
 		   , { macro_as_string = priostring id +++ cpp pd
-		     , macro_extras = {zero & te_priority = findPrio id >>= 'T'.toMaybePriority, te_documentation = findDoc id st}
+		     , macro_extras =
+		       { zero
+		       & te_priority = findPrio id >>= 'T'.toMaybePriority
+		       , te_documentation = findDoc parseFunctionDoc id st
+		       }
 		     }
 		   ) \\ pd=:(PD_Function pos id isinfix args rhs FK_Macro) <- dcl]
 	where
@@ -137,14 +142,15 @@ where
 		   , [('T'.toType gc_type, cpp gc_type, 'DB'.Location lib mod (toLine gc_pos) Nothing "")]
 		   ) \\ PD_Derive gcdefs <- dcl, {gc_type,gc_pos,gc_gcf=GCF id _} <- gcdefs]
 
-	pd_generics :: String String [ParsedDefinition] (Maybe ParsedModule)
+	pd_generics :: String String [ParsedDefinition] (Maybe ParsedModule) SymbolTable
 		-> [('DB'.Location, 'DB'.ExtendedType)]
-	pd_generics lib mod dcl icl
+	pd_generics lib mod dcl icl st
 		= [( 'DB'.Location lib mod (toLine gen_pos) (findIclLine id_name =<< icl) id_name
 		   , 'DB'.ET ('T'.toType gen_type)
 		       {zero & te_generic_vars=Just $ map 'T'.toTypeVar gen_vars
-		             , te_representation=Just $ cpp gen}
-		   ) \\ gen=:(PD_Generic {gen_ident={id_name},gen_pos,gen_type,gen_vars}) <- dcl]
+		             , te_representation=Just $ cpp gen
+		             , te_documentation = findDoc parseFunctionDoc id st}
+		   ) \\ gen=:(PD_Generic {gen_ident=id=:{id_name},gen_pos,gen_type,gen_vars}) <- dcl]
 	where
 		findIclLine :: String ParsedModule -> Maybe Int
 		findIclLine name {mod_defs=pms}
@@ -160,7 +166,7 @@ where
 		   , 'DB'.ET ('T'.toType t)
 		       { zero & te_priority = 'T'.toMaybePriority p
 		              , te_representation = Just $ cpp ts
-		              , te_documentation = findDoc id st}
+		              , te_documentation = findDoc parseFunctionDoc id st}
 		   ) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- dcl]
 	where
 		findIclLine :: String ParsedModule -> Maybe Int
@@ -233,11 +239,6 @@ where
 	toLine (LinePos _ l)  = Just l
 	toLine _              = Nothing
 
-	findDoc :: Ident SymbolTable -> Maybe FunctionDocumentation
-	findDoc {id_info} st = case sreadPtr id_info st of
-		{ste_doc=Yes doc} = Just doc
-		_                 = Nothing
-
 	readModule :: Bool *World -> *(Either String ParsedModule, SymbolTable, *World)
 	readModule icl w
 	# ht = newHashTable newHeap
@@ -257,6 +258,15 @@ where
 		# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
 		= ((b1,b2,pm,ht,f),fs)
 
+	findDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
+		Ident SymbolTable -> Maybe Documentation
+	findDoc parse {id_info} st = case sreadPtr id_info st of
+		{ste_doc=Yes doc} = case parse doc of
+			(Right (doc,ws)) = traceParseWarnings (filter (not o isUsedReturn) ws) (Just doc)
+			(Left e)         = traceParseError e Nothing
+		_                 = Nothing
+	where isUsedReturn UsedReturn = True; isUsedReturn _ = False
+
 constructor_functions :: ('DB'.Location, 'DB'.TypeDef)
 	-> [('DB'.Location, 'DB'.ExtendedType)]
 constructor_functions ('DB'.Builtin _, td)

libcloogle @ f5c802b0

-Subproject commit bdcb93a5690f9b7f77f894834ef8b6044b6c9253
+Subproject commit f5c802b031bf8de328d3155d17ce082b3ee6c156