Commit 53923823 authored by Steffen Michels's avatar Steffen Michels

Merge branch '68-clean.doc-singleline-on-new-line' into 'master'

Resolve "Clean.Parse.Comments does not accept doclines on the next line"

Closes #68

See merge request !265
parents b3c4de5a c3657836
Pipeline #28107 passed with stage
in 3 minutes and 8 seconds
......@@ -3,10 +3,17 @@ test-nightly:
- install_clean.sh bundle-complete
- apt-get update -qq
- apt-get install -y -qq build-essential git coreutils libsnappy-dev
- make -C src/cdeps install
- git clone https://gitlab.science.ru.nl/clean-compiler-and-rts/compiler tests/linux64/compiler
- make -j -C tests/linux64/compiler/main/Unix
- make -j -C tests/linux64/compiler/backendC/CleanCompilerSources -f Makefile.linux64
- mkdir -p tests/linux64/compiler/backend/Clean\ System\ Files
- ln -fs ../../backendC/CleanCompilerSources/backend.a tests/linux64/compiler/backend/Clean\ System\ Files/backend_library
image: "camilstaps/clean:nightly"
script:
- make -C tests/linux64 run
- COCLPATH=./compiler make -C tests/linux64 run
- stdbuf -o0 -e0 testproperties -IL Dynamics -d src/libraries/OS-Independent -P Quiet -r -T 'Tests 100000' -C -h -C 100m
test-stable:
......
......@@ -125,6 +125,8 @@ scan ss=:{idx}
-> scan (advance ss)
['\n':_]
-> scan {ss & idx=idx+1, ln=ss.ln+1, col=0}
['\t':_] // We assume that there are no tabs within a line: each tab counts as 4 characters
-> scan {ss & idx=idx+1, col=ss.col+4}
['//':_] | ss.comment_level == 0
# cmnt =
{ line = ss.ln
......@@ -245,7 +247,7 @@ collectComments comments pm
# (_,_,coll) = collect comments Nothing pm.mod_defs coll
= coll
collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, commentIndex, children a
collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, singleLineAbove, commentIndex, 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)
......@@ -253,9 +255,9 @@ collect [{content}:cs] prev pds coll | not (startsWith "*" content) = collect cs
collect allcmnts=:[c:cs] prev allpds=:[pd:pds] coll = case c canBelongTo pd of
Nothing -> collect allcmnts prev pds coll
Just True -> case prev of
Just prev | prev.multiline && not c.multiline
Just prev | not (singleLineAbove pd) && not c.multiline
# coll = putCC pd prev coll
# (allcmnts,prev,coll) = recurse allcmnts (Just c) (children pd) coll
# (allcmnts,prev,coll) = recurse allcmnts Nothing (children pd) coll
-> collect allcmnts prev pds coll
_
-> collect cs (Just c) allpds coll
......@@ -271,7 +273,7 @@ where
recurse cs prev (Children xs) coll = collect cs prev xs coll
collect _ _ _ _ = abort "internal error in Clean.Parse.Comments.collect\n"
:: Children = E.t: Children ![t] & pos, commentIndex, children t
:: Children = E.t: Children ![t] & pos, singleLineAbove, commentIndex, children t
class children a :: !a -> Children
......@@ -290,11 +292,22 @@ where
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
(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos, singleLineAbove a
(canBelongTo) {line,column,multiline} elem
| singleLineAbove elem && column > 4
= Just False
| not (singleLineAbove elem) && column < 4
= Just False
= pos elem >>= \p -> case p of
FunPos _ ln _ -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
LinePos _ ln -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
_ -> Nothing
// If true, single-line documentation should be given above the element.
class singleLineAbove a :: !a -> Bool
instance singleLineAbove ParsedDefinition where singleLineAbove _ = True
instance singleLineAbove ParsedSelector where singleLineAbove _ = False
instance singleLineAbove ParsedConstructor where singleLineAbove _ = False
class pos a :: !a -> Maybe Position
......
commentstest
gentest
snappytest
tartest
......
......@@ -15,12 +15,19 @@ CLMLIBS:=\
-IL GraphCopy\
-IL TCPIP
BINARIES:=checktest test gentest snappytest tartest
COCLPATH?=../../../compiler
COCLLIBS:=\
-IL ArgEnv\
-I $(COCLPATH)/frontend\
-I $(COCLPATH)/main\
-I $(COCLPATH)/main/Unix
BINARIES:=checktest test commentstest gentest snappytest tartest
RUN_BINARIES:=$(addprefix run_,$(BINARIES))
all: $(RUN_BINARIES)
$(filter-out checktest tartest snappytest,$(BINARIES)): .FORCE
$(filter-out checktest commentstest tartest snappytest,$(BINARIES)): .FORCE
$(CLM) $(CLMLIBS) -PABC StdEnv
$(CLM) $(CLMLIBS) -PABC StdMaybe
$(CLM) $(CLMLIBS) -PABC -dynamics _SystemDynamic
......@@ -50,6 +57,9 @@ run_tartest: tartest
diff -r _tartest-old _tartest
$(RM) -r _tartest-old _tartest _tartest.tar
commentstest: .FORCE
$(CLM) $(CLMLIBS) $(COCLLIBS) -nr -nt $@ -o $@
clean:
$(RM) -r $(filter-out checktest,$(BINARIES)) _tartest* Clean\ System\ Files
......
definition module commentstest
/**
* This module is used to test the Clean documentation parser in Clean.Parse.Comments.
* The documentation here is written obscurely on purpose!
*/
import syntax
import Clean.Parse.Comments
//* A documentation entry
:: Entry =
{ kind :: !String //* the kind of thing that is documented
, name :: !String
//* the name of the documented thing
, value :: !Maybe String
}
//* This type is just here to test; it isn't used
:: TrickyADT
= TrickyADT_A
//* Documentation on new line
list_comments :: !ParsedModule !CollectedComments -> [Entry]
// Don't add a comment for this function: we want to check that the last comment
// of TrickyADT is not added to list_comments_of_definitions.
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"}
, {kind="constructor", name="TrickyADT_A", value=Just "* Documentation on new line\n"}
, {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
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment