commentstest.icl 3.92 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
implementation module commentstest

import StdEnv
import StdMaybe

import Clean.Parse
import Clean.Parse.Comments
import Data.Error
import Data.Func
import Data.GenDiff
import System.CommandLine
from Text import class Text(replaceSubString,trim), instance Text String

import syntax

dcl = "commentstest.dcl"

Start w
# (Ok (mod,_), w) = readModule dcl w
# (Ok comments, w) = scanComments dcl w
# comments = collectComments comments mod 
# comments = list_comments mod comments
# diff = gDiff{|*|} expected comments
# (io,w) = stdio w
# io = io <<< diffToConsole diff <<< "\n"
# (_,w) = fclose io w
# w = let [d:_] = diff in case d.status of
	Common -> w
	_      -> setReturnCode -1 w
= w

expected :: [Entry]
expected =
	[ {kind="module",   name="commentstest",   value=Just "*\n * This module is used to test the Clean documentation parser in Clean.Parse.Comments.\n * The documentation here is written obscurely on purpose!\n "}
	, {kind="type",     name="Entry",          value=Just "* A documentation entry\n"}
	, {kind="selector",    name="kind",        value=Just "* the kind of thing that is documented\n"}
	, {kind="selector",    name="name",        value=Just "* the name of the documented thing\n"}
	, {kind="selector",    name="value",       value=Nothing}
	, {kind="type",     name="TrickyADT",      value=Just "* This type is just here to test; it isn't used\n"}
40
	, {kind="constructor", name="TrickyADT_A", value=Just "* Documentation on same line\n"}
41 42 43
	, {kind="constructor", name="TrickyADT_B", value=Just "* New constructor with matching column\n"}
	, {kind="constructor", name="TrickyADT_C", value=Just "* Documentation on new line\n* Extra documentation line\n"}
	, {kind="constructor", name="TrickyADT_D", value=Just "* Documentation on new line\n"}
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
	, {kind="typespec", name="list_comments",  value=Nothing}
	]

derive gDiff Entry, Maybe

list_comments :: !ParsedModule !CollectedComments -> [Entry]
list_comments mod comments
# entry =
	{ kind  = "module"
	, name  = mod.mod_ident.id_name
	, value = getComment mod comments
	}
= [entry:list_comments_of_definitions mod.mod_defs comments]

list_comments_of_definitions :: ![ParsedDefinition] !CollectedComments -> [Entry]
list_comments_of_definitions [] _ = []
list_comments_of_definitions [pd:pds] comments = case pd of
	PD_Type {td_ident,td_rhs}
		# entry =
			{ kind = "type", name = td_ident.id_name
			, value = getComment pd comments
			}
		-> [entry:list_comments_of_type_rhs td_rhs comments ++
			list_comments_of_definitions pds comments]
	PD_TypeSpec _ id _ _ _
		# entry =
			{ kind = "typespec", name = id.id_name
			, value = getComment pd comments
			}
		-> [entry:list_comments_of_definitions pds comments]
	PD_Class cd _
		# entry =
			{ kind = "class", name = cd.class_ident.id_name
			, value = getComment pd comments
			}
		-> [entry:list_comments_of_definitions pds comments]
	PD_Generic gd
		# entry =
			{ kind = "generic", name = gd.gen_ident.id_name
			, value = getComment pd comments
			}
		-> [entry:list_comments_of_definitions pds comments]
	_
		-> list_comments_of_definitions pds comments

list_comments_of_type_rhs :: !RhsDefsOfType !CollectedComments -> [Entry]
list_comments_of_type_rhs rhs comments = case rhs of
	ConsList           pcs -> map (flip comment_of_constructor comments) pcs
	ExtensibleConses   pcs -> map (flip comment_of_constructor comments) pcs
	MoreConses _       pcs -> map (flip comment_of_constructor comments) pcs
	SelectorList _ _ _ pss -> map (flip comment_of_selector comments) pss
	TypeSpec _ -> []
	NewTypeCons _ -> []
	EmptyRhs _ -> []
	AbstractTypeSpec _ _ -> []
where
	comment_of_selector :: !ParsedSelector !CollectedComments -> Entry
	comment_of_selector ps comments =
		{ kind = "selector", name = ps.ps_field_ident.id_name
		, value = getComment ps comments
		}

	comment_of_constructor :: !ParsedConstructor !CollectedComments -> Entry
	comment_of_constructor pc comments =
		{ kind = "constructor", name = pc.pc_cons_ident.id_name
		, value = getComment pc comments
		}