Add Clean.Doc, Clean.Parse, Clean.Parse.Comments

src/libraries/OS-Independent/Clean/Doc.dcl

+definition module Clean.Doc
+
+/**
+ * Parsing and storing Clean documentation
+ */
+
+import StdGeneric
+from StdOverloaded import class toString
+
+from Data.Either import :: Either
+from Data.GenDefault import generic gDefault
+from Data.Maybe import :: Maybe
+
+from Clean.Types import :: Type
+
+/**
+ * A wrapper around the {{`String`}} type which makes sure that multi-line
+ * documentation blocks get trimmed w.r.t. whitespace.
+ */
+:: MultiLineString = MultiLine !String
+
+class docDescription            d :: !d -> Maybe Description
+class docComplexity             d :: !d -> Maybe String
+class docParams                 d :: !d -> [ParamDoc]
+class docVars                   d :: !d -> [Description]
+class docResults                d :: !d -> [Description]
+class docType                   d :: !d -> Maybe Type
+class docThrows                 d :: !d -> [Description]
+class docMembers                d :: !d -> [Maybe ClassMemberDoc]
+class docFields                 d :: !d -> Maybe [Maybe Description]
+class docConstructors           d :: !d -> Maybe [Maybe ConstructorDoc]
+class docRepresentation         d :: !d -> Maybe (Maybe Description)
+class docPropertyBootstrap      d :: !d -> Maybe String
+class docPropertyTestWith       d :: !d -> [PropertyVarInstantiation]
+class docPropertyTestGenerators d :: !d -> [PropertyTestGenerator]
+class docProperties             d :: !d -> [Property]
+
+/**
+ * Documentation of a Clean module.
+ */
+:: ModuleDoc =
+	{ description        :: !Maybe Description
+	, property_bootstrap :: !Maybe MultiLineString      //* For generating unit tests with clean-test
+	, property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties
+	, property_test_generators :: ![PropertyTestGenerator]
+	  //* Functions to generate values of types for which Gast's {{`ggen`}} is not good enough, like {{`Map`}}
+	}
+
+instance docDescription ModuleDoc
+instance docPropertyBootstrap ModuleDoc
+instance docPropertyTestWith ModuleDoc
+instance docPropertyTestGenerators ModuleDoc
+derive gDefault ModuleDoc
+
+/**
+ * Documentation of a Clean function.
+ */
+:: FunctionDoc =
+	{ description        :: !Maybe Description
+	, complexity         :: !Maybe String  //* E.g. "O(n log n)"
+	, params             :: ![ParamDoc]    //* Descriptions of the parameters
+	, vars               :: ![Description] //* Descriptions of the type variables (for generics)
+	, results            :: ![Description] //* Descriptions of the result(s, for tuples)
+	, type               :: !Maybe Type    //* The type (for macros)
+	, throws             :: ![Description] //* The exceptions it may throw (iTasks)
+	, properties         :: ![Property]    //* Properties of this function
+	, property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties
+	, preconditions      :: ![String]      //* Preconditions for the properties
+	}
+
+instance docDescription FunctionDoc
+instance docComplexity FunctionDoc
+instance docParams FunctionDoc
+instance docVars FunctionDoc
+instance docResults FunctionDoc
+instance docType FunctionDoc
+instance docThrows FunctionDoc
+instance docPropertyTestWith FunctionDoc
+instance docProperties FunctionDoc
+
+/**
+ * Documentation of a function parameter.
+ */
+:: ParamDoc =
+	{ name        :: !Maybe String      //* An optional name for the parameter
+	, description :: !Maybe Description //* An optional description
+	}
+
+instance toString ParamDoc
+instance docDescription ParamDoc
+
+/**
+ * A property of a function.
+ * Typically, the property can be tested with Gast.
+ *
+ * - `ForAll`: the right-hand side (the third argument) holds for all values of
+ *   the arguments (the second argument). The first argument is the name.
+ */
+:: Property
+	= ForAll !String ![(!String,!Type)] !String
+
+/**
+ * When a property type contains type variables, a `PropertyVarInstantiation`
+ * can be used to instantiate those variables when generating test cases.
+ */
+:: PropertyVarInstantiation = PropertyVarInstantiation !(!String, !Type)
+
+/**
+ * A test generator generates values of some type. The first argument of the
+ * constructor is the function type of the generator, for instance
+ * `[(k,v)] -> {{Map}} k v`. The second argument is the implementation, which
+ * should assume the generator is called `gen` (e.g.: `gen elems = ...`).
+ */
+:: PropertyTestGenerator = PropertyTestGenerator !Type !String
+
+derive gDefault FunctionDoc, Property, PropertyVarInstantiation, PropertyTestGenerator
+
+/**
+ * Documentation of a Clean class member.
+ * For an explanation of the fields, see the documentation on {{`FunctionDoc`}}.
+ */
+:: ClassMemberDoc =
+	{ description :: !Maybe Description
+	, complexity  :: !Maybe String
+	, params      :: ![ParamDoc]
+	, results     :: ![Description]
+	, type        :: !Maybe Type
+	, throws      :: ![Description]
+	}
+
+instance docDescription ClassMemberDoc
+instance docComplexity ClassMemberDoc
+instance docParams ClassMemberDoc
+instance docResults ClassMemberDoc
+instance docType ClassMemberDoc
+instance docThrows ClassMemberDoc
+derive gDefault ClassMemberDoc
+
+/**
+ * Documentation of a Clean ADT constructor.
+ * For an explanation of the fields, see the documentation on {{`FunctionDoc`}}.
+ */
+:: ConstructorDoc =
+	{ description :: !Maybe Description
+	, params      :: ![ParamDoc]
+	}
+
+instance docDescription ConstructorDoc
+instance docParams ConstructorDoc
+derive gDefault ConstructorDoc
+
+/**
+ * Documentation of a Clean class.
+ */
+:: ClassDoc =
+	{ description :: !Maybe Description
+	, vars        :: ![Description]          //* The type variables
+	, members     :: ![Maybe ClassMemberDoc] //* Documentation on the members
+	}
+
+instance docDescription ClassDoc
+instance docVars ClassDoc
+instance docMembers ClassDoc
+derive gDefault ClassDoc
+
+/**
+ * Documentation of a Clean type.
+ */
+:: TypeDoc =
+	{ description    :: !Maybe Description
+	, vars           :: ![Description]                //* Type variables
+	, representation :: !Maybe (Maybe Description)    //* For synonym types
+	, fields         :: !Maybe [Maybe Description]    //* For records
+	, constructors   :: !Maybe [Maybe ConstructorDoc] //* For ADTs
+	}
+
+instance docDescription TypeDoc
+instance docVars TypeDoc
+instance docFields TypeDoc
+instance docConstructors TypeDoc
+instance docRepresentation TypeDoc
+derive gDefault TypeDoc
+
+/**
+ * Description of a Clean syntax element
+ */
+:: Description :== String
+
+/**
+ * Parse error for parsing Clean documentation; no documentation could be found
+ */
+:: ParseError
+	= MissingAsterisk !String //* At least one line did not start with a *
+	| MissingField !String    //* A required field was missing
+	| UnknownError !String    //* Another error
+	| InternalNoDataError
+
+/**
+ * Parse warning while parsing Clean documentation; the parser has made a
+ * best-effort result nevertheless
+ */
+:: 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
+	| UnparsableType !String //* Could not parse a @type field as a type
+
+/**
+ * Convert a ConstructorDoc to a FunctionDoc.
+ */
+constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc
+
+/**
+ * Convert a FunctionDoc to a ClassMemberDoc.
+ */
+functionToClassMemberDoc :: !FunctionDoc -> ClassMemberDoc
+
+/**
+ * Add a class member to an existing class definition
+ *
+ * @param The documentation to add the member to
+ * @param The documentation on the class member
+ * @result The new ClassDoc
+ */
+addClassMemberDoc :: !ClassDoc !(Maybe ClassMemberDoc) -> ClassDoc
+
+/**
+ * Parse a single docstring, removing the asterisk and trimming whitespace.
+ */
+parseSingleLineDoc :: (String -> String)
+
+/**
+ * Parse a documentation block. The magic happens in {{`docBlockToDoc`}}.
+ */
+parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|*|} d
+
+/**
+ * A documentation block.
+ * @representation An order list of key-value pairs. A key can occur multiple
+ *   times. The description has key `description`.
+ */
+:: DocBlock :== [(!String, !String)]
+
+/**
+ * The magic for {{`parseDoc`}}. Usually, a record type like {{`FunctionDoc`}}
+ * will derive a convenient parser. In some cases, it may be necessary to
+ * override the default, such as in the instance for {{`Type`}}, where parsing
+ * of the type happens.
+ * @var The thing to parse
+ */
+generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ![ParseWarning])
+
+derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of d, RECORD
+derive docBlockToDoc String, [], Maybe, Type
+derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
+	ConstructorDoc, TypeDoc
+
+/**
+ * Trace a list of ParseWarnings like StdDebug might do it
+ */
+traceParseWarnings :: ![ParseWarning] !a -> a
+
+/**
+ * Trace a ParseError like StdDebug might do it
+ */
+traceParseError :: !ParseError !a -> a

src/libraries/OS-Independent/Clean/Doc.icl

+implementation module Clean.Doc
+
+import _SystemArray
+import StdBool
+import StdChar
+import StdDebug
+from StdFunc import flip, o, twice
+import StdList
+import StdMisc
+import StdOrdList
+import StdString
+import StdTuple
+
+import Control.Applicative
+import Control.Monad => qualified join
+import Data.Either
+import Data.Error
+from Data.Func import $
+import Data.Functor
+import Data.GenDefault
+import Data.List
+import Data.Maybe
+import Data.Tuple
+from Text import class Text(join,split,trim,rtrim),
+	instance Text String, instance Text [Char]
+import Text.Language
+import Text.Parsers.Simple.ParserCombinators
+
+from Clean.Types import :: Type, :: TypeRestriction
+import qualified Clean.Types.Parse as T
+
+gDefault{|Maybe|} _ = Nothing
+
+fromMultiLine :: !MultiLineString -> String
+fromMultiLine (MultiLine s) = s
+
+instance docDescription       ModuleDoc where docDescription       d = d.ModuleDoc.description
+instance docPropertyBootstrap ModuleDoc where docPropertyBootstrap d = fromMultiLine <$> d.property_bootstrap
+instance docPropertyTestWith  ModuleDoc where docPropertyTestWith  d = d.ModuleDoc.property_test_with
+instance docPropertyTestGenerators ModuleDoc where docPropertyTestGenerators d = d.property_test_generators
+
+instance docDescription      FunctionDoc where docDescription      d = d.FunctionDoc.description
+instance docComplexity       FunctionDoc where docComplexity       d = d.FunctionDoc.complexity
+instance docParams           FunctionDoc where docParams           d = d.FunctionDoc.params
+instance docVars             FunctionDoc where docVars             d = d.FunctionDoc.vars
+instance docResults          FunctionDoc where docResults          d = d.FunctionDoc.results
+instance docType             FunctionDoc where docType             d = d.FunctionDoc.type
+instance docThrows           FunctionDoc where docThrows           d = d.FunctionDoc.throws
+instance docProperties       FunctionDoc where docProperties       d = d.properties
+instance docPropertyTestWith FunctionDoc where docPropertyTestWith d = d.FunctionDoc.property_test_with
+
+instance docDescription ParamDoc where docDescription d = d.ParamDoc.description
+
+instance docDescription ClassMemberDoc where docDescription d = d.ClassMemberDoc.description
+instance docComplexity  ClassMemberDoc where docComplexity  d = d.ClassMemberDoc.complexity
+instance docParams      ClassMemberDoc where docParams      d = d.ClassMemberDoc.params
+instance docResults     ClassMemberDoc where docResults     d = d.ClassMemberDoc.results
+instance docType        ClassMemberDoc where docType        d = d.ClassMemberDoc.type
+instance docThrows      ClassMemberDoc where docThrows      d = d.ClassMemberDoc.throws
+
+instance docDescription ConstructorDoc where docDescription d = d.ConstructorDoc.description
+instance docParams      ConstructorDoc where docParams      d = d.ConstructorDoc.params
+
+instance docDescription ClassDoc where docDescription d = d.ClassDoc.description
+instance docVars        ClassDoc where docVars        d = d.ClassDoc.vars
+instance docMembers     ClassDoc where docMembers     d = d.ClassDoc.members
+
+instance docDescription    TypeDoc where docDescription    d = d.TypeDoc.description
+instance docVars           TypeDoc where docVars           d = d.TypeDoc.vars
+instance docFields         TypeDoc where docFields         d = d.TypeDoc.fields
+instance docConstructors   TypeDoc where docConstructors   d = d.TypeDoc.constructors
+instance docRepresentation TypeDoc where docRepresentation d = d.TypeDoc.representation
+
+instance toString ParamDoc
+where
+	toString pd=:{name=Just n,description=Just d} = n +++ ": " +++ d
+	toString {ParamDoc | description=Just d} = d
+	toString _ = ""
+
+derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, ClassMemberDoc,
+	ConstructorDoc, ClassDoc, TypeDoc, Property, PropertyVarInstantiation,
+	MultiLineString, PropertyTestGenerator, ParamDoc
+
+constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc
+constructorToFunctionDoc d =
+	{ FunctionDoc
+	| gDefault{|*|}
+	& description = d.ConstructorDoc.description
+	, params      = d.ConstructorDoc.params
+	}
+
+functionToClassMemberDoc :: !FunctionDoc -> ClassMemberDoc
+functionToClassMemberDoc d =
+	{ ClassMemberDoc
+	| description = d.FunctionDoc.description
+	, complexity  = d.FunctionDoc.complexity
+	, params      = d.FunctionDoc.params
+	, results     = d.FunctionDoc.results
+	, type        = d.FunctionDoc.type
+	, throws      = d.FunctionDoc.throws
+	}
+
+addClassMemberDoc :: !ClassDoc !(Maybe ClassMemberDoc) -> ClassDoc
+addClassMemberDoc d m = {d & members=d.members ++ [m]}
+
+parseSingleLineDoc :: (String -> String)
+parseSingleLineDoc = toString o trim o dropWhile ((==) '*') o fromString
+
+parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|*|} d
+parseDoc s = docBlockToDoc{|*|} (Left [s])
+
+generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ![ParseWarning])
+docBlockToDoc{|String|} (Left []) = Left InternalNoDataError
+docBlockToDoc{|String|} (Left ss) = Right (trim $ last ss, [])
+docBlockToDoc{|[]|} fx (Left ss) = (\vws -> (map fst vws, flatten (map snd vws)) ) <$> mapM fx (map (Left o pure) ss)
+docBlockToDoc{|Maybe|} fx (Left []) = Right (Nothing, [])
+docBlockToDoc{|Maybe|} fx ss=:(Left _) = appFst Just <$> fx ss
+docBlockToDoc{|UNIT|} _ = Right (UNIT, [])
+docBlockToDoc{|PAIR|} fx fy db=:(Right _) = liftA2 (\(x,ws) (y,ws`) -> (PAIR x y, ws ++ ws`)) (fx db) (fy db)
+docBlockToDoc{|FIELD of d|} fx (Right db) = case fx (Left [v \\ (k,v) <- db | k matches d.gfd_name]) of
+	Right (f, ws)            -> Right (FIELD f, ws)
+	Left InternalNoDataError -> Left (MissingField d.gfd_name)
+	Left e                   -> Left e
+where
+	(matches) infix 4 :: !String !String -> Bool
+	(matches) k name =
+		k` == name ||
+		pluralise English k` == name ||
+		k` == "return" && name == "result" ||
+		k` == "return" && name == "results"
+	where
+		k` = {if (c == '-') '_' c \\ c <-: k}
+docBlockToDoc{|RECORD|} fx (Left [s]) = case parseDocBlock s of
+	Right (db, ws) -> case fx (Right db) of
+		Right (v, ws`) -> Right (RECORD v, ws ++ ws`)
+		Left e -> Left e
+	Left e -> Left e
+docBlockToDoc{|RECORD|} fx doc = appFst RECORD <$> fx doc
+docBlockToDoc{|CONS|} fx doc = appFst CONS <$> fx doc
+docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
+	Right (v, ws) -> Right (LEFT v, ws)
+	Left e -> case fr doc of
+		Right (v, ws) -> Right (RIGHT v, ws)
+		Left _ -> Left e
+docBlockToDoc{|OBJECT|} fx doc = appFst OBJECT <$> fx doc
+
+docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine $ trimMultiLine $ split "\n" s, [])
+
+docBlockToDoc{|ParamDoc|} (Left [s]) = case findName (fromString s) of
+	Just (name,rest) -> Right (
+		{ name        = Just $ toString name
+		, description = case rest of
+			[] -> Nothing
+			_  -> Just $ toString rest
+		}, [])
+	_                -> Right ({name=Nothing, description=Just s}, [])
+where
+	findName cs
+	# (name,cs) = span (\c -> isAlphanum c || c == '`') cs
+	| not (isEmpty name) && not (isEmpty cs) && hd cs == ':'
+		= Just (toString name, dropWhile isSpace (tl cs))
+		= Nothing
+
+docBlockToDoc{|Type|} (Left []) = Left InternalNoDataError
+docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map ('T'.parseType o fromString) ss] of
+	[] -> Left (UnknownError "no parsable type")
+	vs -> Right (last vs, [])
+
+docBlockToDoc{|Property|} (Left [s]) = let [signature:property] = split "\n" s in
+		parseSignature signature >>= \(sig,ws1) ->
+		parseProperty property >>= \(prop,ws2) ->
+		Right (sig prop, ws1 ++ ws2)
+where
+	parseSignature :: !String -> Either ParseError (!String -> Property, ![ParseWarning])
+	parseSignature s = case parse parser (fromString s) of
+		Left es           -> Left (UnknownError "failed to parse property signature")
+		Right (name,args) -> Right (ForAll name args, [])
+	where
+		parser :: Parser Char (!String, ![(!String, !Type)])
+		parser = skipSpaces *>
+			pMany (pSatisfy ((<>) ':')) >>= \name ->
+			skipSpaces *> pToken ':' *>
+			((skipSpaces *> pToken 'A' *> pToken '.' *>
+			pMany
+				(skipSpaces *>
+				(liftA2 tuple
+					(toString <$> pMany (pSatisfy (not o isSpace)))
+					(pList [skipSpaces,pToken ':',pToken ':',skipSpaces] *> pTypeWithColonOrSemicolon)
+				) <* skipSpaces)) <|> skipSpaces *> pure []) >>= \args ->
+			pure (toString name, args)
+
+		skipSpaces = pMany (pSatisfy isSpace) *> pYield undef
+		pTypeWithColonOrSemicolon = (pMany (pSatisfy \c -> c <> ':' && c <> ';') <* pOneOf [':;'])
+			>>= \t -> case 'T'.parseType t of
+				Nothing -> pError "type could not be parsed"
+				Just t  -> pure t
+
+	parseProperty :: ![String] -> Either ParseError (!String, ![ParseWarning])
+	parseProperty ss = Right (trimMultiLine ss, [])
+
+docBlockToDoc{|PropertyVarInstantiation|} (Left [s]) = case split "=" s of
+	[var:type:[]] -> case 'T'.parseType (fromString type) of
+		Just t -> Right (PropertyVarInstantiation (trim var, t), [])
+		Nothing -> Left (UnknownError "type could not be parsed")
+	_ -> Left (UnknownError "property var instantiation could not be parsed")
+
+docBlockToDoc{|PropertyTestGenerator|} (Left [s]) = case 'T'.parseType (fromString sig) of
+	Just t -> Right (PropertyTestGenerator t (trimMultiLine imp), [])
+	Nothing -> Left (UnknownError "type could not be parsed")
+where
+	[sig:imp] = split "\n" s
+
+derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ConstructorDoc,
+	ClassDoc, TypeDoc
+
+trimMultiLine :: ![String] -> String
+trimMultiLine ss = join "\n" [s % (trimn, size s - 1) \\ s <- ss]
+where
+	trimn = minList [i \\ Just i <- map (firstNonSpace 0) ss]
+
+	firstNonSpace :: !Int !String -> Maybe Int
+	firstNonSpace i s
+	| i >= size s   = Nothing
+	| isSpace s.[i] = firstNonSpace (i+1) s
+	| otherwise     = Just i
+
+parseDocBlock :: !String -> Either ParseError (!DocBlock, ![ParseWarning])
+parseDocBlock b = prepareString b >>= parsef
+where
+	parsef :: ![[Char]] -> Either ParseError (!DocBlock, ![ParseWarning])
+	parsef [] = Right ([], [])
+	parsef lines = case span (\l -> isEmpty l || hd l <> '@') lines of
+		([],   [ln]) = parseFields [ln]
+		([],   rest) = appSnd (\ws -> [NoDescription:ws]) <$> parseFields rest
+		(desc, rest) = appFst (\d -> [("description", linesToString desc):d]) <$> parseFields rest
+
+	parseFields :: ![[Char]] -> Either ParseError (!DocBlock, ![ParseWarning])
+	parseFields []
+		= Right ([], [])
+	parseFields [['@':line]:rest]
+		= parseFields rest` >>=
+			\(d,ws) -> appSnd ((++) ws) <$> parseFs field desc d
+	where
+		(field, descline) = span (not o isSpace) line
+		(restdesc, rest`) = span (\l -> isEmpty l || hd l <> '@') rest
+		desc = flatten $ intersperse ['\n'] $ if (isEmpty descline) restdesc [tl descline:restdesc]
+
+		parseFs :: ![Char] ![Char] !DocBlock -> Either ParseError (!DocBlock, ![ParseWarning])
+		parseFs field val d = Right ([(toString field,toString (rtrim val)):d], [])
+
+prepareString :: (String -> Either ParseError [[Char]])
+prepareString = checkAsterisks o map trim o break '\n' o fromString
+where
+	checkAsterisks :: ![[Char]] -> Either ParseError [[Char]]
+	checkAsterisks [['*':line]] = Right [safetl line]
+	checkAsterisks [line] = Right [line]
+	checkAsterisks lines
+	| all (\l -> isEmpty l || hd l == '*') lines
+		= Right $ map (safetl o dropWhile ((==) '*')) lines
+		= Left $ MissingAsterisk $ toString $ hd $ filter (\l -> not (isEmpty l) && hd l <> '*') lines
+
+	safetl :: ![a] -> [a]
+	safetl []     = []
+	safetl [_:xs] = xs
+
+	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]
+
+linesToString :: ([[Char]] -> String)
+linesToString = toString o flatten o intersperse ['\n']
+
+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 (UnparsableType t) = "Doc warning: could not parse type '" +++ t +++ "'"
+
+instance toString ParseError
+where
+	toString (MissingAsterisk l) = "Doc error: missing leading asterisk in '" +++ l +++ "'"
+	toString (MissingField f)    = "Doc error: required field '" +++ f +++ "' was missing"
+	toString (UnknownError e)    = "Doc error: " +++ e
+