...
 
Commits (250)
Clean System Files
_Tests
_Tests.*
*.abc
*.bc
*.o
*-sapl
*-www
*-data
*.tcl
*.prj
*.prp
* Time Profile.pcl
*.exe
a.out
* Time Profile.pcl
_Tests
_Tests.*
......@@ -2,20 +2,22 @@ test-nightly:
before_script:
- 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
image: "camilstaps/clean:nightly"
script:
- 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
- apt-get install -y -qq build-essential git coreutils libmariadb-dev librdkafka-dev libsnappy-dev libsqlite3-dev
test-stable:
before_script:
- apt-get update -qq
- apt-get install -y -qq patch build-essential coreutils libsnappy-dev
- make -C src/cdeps install
- install_clean.sh "stable lib-dynamics lib-tcpip lib-graphcopy lib-graphcopy test"
- git clone https://gitlab.science.ru.nl/clean-compiler-and-rts/compiler tests/linux64/compiler
- make -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
allow_failure: true
- COCLPATH=./compiler make -C tests/linux64 run
- cleantest -r testproperties --options '-IL;Dynamics;-d;src/libraries/OS-Independent;-P;OutputTestEvents;-T;Tests 100000;-T;MaxStringLength 500;-T;Bent;-C;-h;-C;100m;-r' --junit junit.xml
artifacts:
when: always
paths:
- junit.xml
reports:
junit: junit.xml
......@@ -23,8 +23,7 @@ map :: (a -> b) [a] -> [b]
For short documentation items, doclines, starting with `//*` can be used. When
documenting a constructor, or record field, they should be placed *after* the
item they document. Doclines are only supported for constructors and record
fields. For example:
item they document. For example:
```clean
/**
......@@ -37,6 +36,23 @@ fields. For example:
}
```
To add several lines of documentation to a constructor or record field, several
doclines can be used:
```clean
:: MyType
= MyConstructor args // ...
//* This constructor may require some more explanation,
//* which is added on several lines.
```
Doclines can also be added *above* a function, type, or class definition:
```clean
//* The identity function.
id :: .a -> .a
```
## Markup in documentation
Some simple Markdown-inspired markup is allowed in documentation:
......@@ -67,7 +83,7 @@ information.
| Constructor | ![][y] | | | | | | |
| Function | ![][y] | ![][y] | ![][y] | | | | ![][y] | ![][y]
| Generic | ![][y] | ![][y] | ![][y] | | ![][y] | | |
| Instance | | | | | | | |
| Instance | ![][y] | | | | | | |
| Macro | ![][y] | ![][y] | ![][y] | ![][y]<sup>2</sup> | | | |
| Module | ![][y] | | | | | | |
| Record field | ![][y] | | | | | | |
......@@ -96,6 +112,18 @@ With [clean-test-properties][]' `testproperties` tool, [Gast][] test programs
can be generated with properties from docblocks. For this, several additional
fields can be used, which are further documented by [clean-test-properties][].
Our [standards](STANDARDS.md) require the use of tabs for indentation and spaces
for outlining. Because with properties code is included in documentation blocks,
using tabs for indentation would lead to tabs after spaces. To avoid this, we
use four spaces in this context instead. For example:
```clean
/**
* @property correctness: A.xs :: Set a:
* minList (toList xs) == findMin xs
*/
```
[clean-test-properties]: https://gitlab.science.ru.nl/clean-and-itasks/clean-test-properties
[Gast]: https://gitlab.science.ru.nl/clean-and-itasks/gast
......
......@@ -97,6 +97,8 @@ collisions, adhere to the following conventions:
Implementation modules may import anything they like.
## Implementing class instances and generic derives
Clean Platform should, where applicable, provide instances for the types it provides for classes defined in StdEnv, Gast, and Platform itself.
The applicable instances for the _general_ classes should be exported in the module of the type and not of the class.
This means that for example the `Functor` instance of `Maybe` should be defined in `Data.Maybe` and not in `Data.Functor`.
......@@ -119,6 +121,7 @@ _general_ classes are:
_specific_ classes are for example:
- [ ] `JSONEncode, JSONDecode` from `Text.JSON`
- [ ] `ggen, genShow` from `Gast`
- [ ] ...
......
......@@ -41,3 +41,8 @@ void signal_poll(long handler, long *ok, long *state, long *handlerr)
*ok = 0;
}
}
int signal_ignore(long signum)
{
return signal(signum, SIG_IGN) == SIG_ERR;
}
......@@ -17,7 +17,7 @@ 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
:: MultiLineString =: MultiLine String
class docDescription d :: !d -> Maybe Description
class docComplexity d :: !d -> Maybe String
......@@ -31,17 +31,18 @@ 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 docPropertyBootstrap d :: !d -> Maybe PropertyBootstrapDoc
class docPropertyTestWith d :: !d -> [PropertyVarInstantiation]
class docPropertyTestGenerators d :: !d -> [PropertyTestGenerator]
class docProperties d :: !d -> [Property]
class docPreconditions d :: !d -> [String]
/**
* Documentation of a Clean module.
*/
:: ModuleDoc =
{ description :: !Maybe Description
, property_bootstrap :: !Maybe MultiLineString //* For generating unit tests with clean-test
, property_bootstrap :: !Maybe PropertyBootstrapDoc //* For generating unit tests with clean-test-properties
, 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`}}
......@@ -51,7 +52,14 @@ instance docDescription ModuleDoc
instance docPropertyBootstrap ModuleDoc
instance docPropertyTestWith ModuleDoc
instance docPropertyTestGenerators ModuleDoc
derive gDefault ModuleDoc
derive gDefault ModuleDoc, PropertyBootstrapDoc
//* Belongs to `property_bootstrap` in `ModuleDoc`.
:: PropertyBootstrapDoc =
{ bootstrap_content :: !MultiLineString
, bootstrap_without_default_imports :: !Bool
//* Don't generate a default set of imports (e.g. to avoid name clashes with Gast)
}
/**
* Documentation of a Clean function.
......@@ -76,8 +84,26 @@ instance docVars FunctionDoc
instance docResults FunctionDoc
instance docType FunctionDoc
instance docThrows FunctionDoc
instance docPropertyTestWith FunctionDoc
instance docProperties FunctionDoc
instance docPropertyTestWith FunctionDoc
instance docPreconditions FunctionDoc
/**
* Documentation of a class instance.
*/
:: InstanceDoc =
{ description :: !Maybe Description
, complexity :: !Maybe String //* E.g. "O(n log n)"
, properties :: ![Property] //* Properties of this instance
, property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties
, preconditions :: ![String] //* Preconditions for the properties
}
instance docDescription InstanceDoc
instance docComplexity InstanceDoc
instance docProperties InstanceDoc
instance docPropertyTestWith InstanceDoc
instance docPreconditions InstanceDoc
/**
* Documentation of a function parameter.
......@@ -98,7 +124,7 @@ instance docDescription ParamDoc
* the arguments (the second argument). The first argument is the name.
*/
:: Property
= ForAll !String ![(!String,!Type)] !String
= ForAll !String ![(String,Type)] !String
/**
* When a property type contains type variables, a `PropertyVarInstantiation`
......@@ -123,7 +149,7 @@ instance docDescription ParamDoc
= PTG_Function !Type !String
| PTG_List !Type !String
derive gDefault FunctionDoc, Property, PropertyVarInstantiation, PropertyTestGenerator
derive gDefault FunctionDoc, InstanceDoc, Property, PropertyVarInstantiation, PropertyTestGenerator
/**
* Documentation of a Clean class member.
......@@ -251,7 +277,7 @@ parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|
* @representation An order list of key-value pairs. A key can occur multiple
* times. The description has key `description`.
*/
:: DocBlock :== [(!String, !String)]
:: DocBlock :== [(String, String)]
/**
* The magic for {{`parseDoc`}}. Usually, a record type like {{`FunctionDoc`}}
......@@ -264,8 +290,8 @@ generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d,
derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of {gfd_name}, RECORD
derive docBlockToDoc String, [], Maybe, Type
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
ConstructorDoc, TypeDoc
derive docBlockToDoc ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ClassDoc, ConstructorDoc, TypeDoc
/**
* Print a documentation block as a string. The magic happens in
......@@ -275,12 +301,11 @@ printDoc :: !d -> String | docToDocBlock{|*|} d
/**
* The magic for {{`printDoc`}}.
* @param If true, return a `Left`. If false, return a `Right`.
*/
generic docToDocBlock d :: !Bool !d -> Either [String] DocBlock
generic docToDocBlock d :: !d -> Either [String] DocBlock
derive docToDocBlock ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
ConstructorDoc, TypeDoc
derive docToDocBlock ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ClassDoc, ConstructorDoc, TypeDoc
/**
* Trace a list of ParseWarnings like StdDebug might do it
......
......@@ -27,7 +27,7 @@ from Text import <+,
import Text.Language
import Text.Parsers.Simple.ParserCombinators
from Clean.Types import :: Type, :: TypeRestriction
from Clean.Types import :: Type, :: TypeRestriction, :: TypeContext
from Clean.Types.Parse import parseType
from Clean.Types.Util import instance toString Type
......@@ -37,7 +37,7 @@ 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 docPropertyBootstrap ModuleDoc where docPropertyBootstrap d = d.property_bootstrap
instance docPropertyTestWith ModuleDoc where docPropertyTestWith d = d.ModuleDoc.property_test_with
instance docPropertyTestGenerators ModuleDoc where docPropertyTestGenerators d = d.property_test_generators
......@@ -48,8 +48,15 @@ instance docVars FunctionDoc where docVars d = d.Functio
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 docProperties FunctionDoc where docProperties d = d.FunctionDoc.properties
instance docPropertyTestWith FunctionDoc where docPropertyTestWith d = d.FunctionDoc.property_test_with
instance docPreconditions FunctionDoc where docPreconditions d = d.FunctionDoc.preconditions
instance docDescription InstanceDoc where docDescription d = d.InstanceDoc.description
instance docComplexity InstanceDoc where docComplexity d = d.InstanceDoc.complexity
instance docProperties InstanceDoc where docProperties d = d.InstanceDoc.properties
instance docPropertyTestWith InstanceDoc where docPropertyTestWith d = d.InstanceDoc.property_test_with
instance docPreconditions InstanceDoc where docPreconditions d = d.InstanceDoc.preconditions
instance docDescription ParamDoc where docDescription d = d.ParamDoc.description
......@@ -79,9 +86,9 @@ where
toString {ParamDoc | description=Just d} = d
toString _ = ""
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, ClassMemberDoc,
ConstructorDoc, ClassDoc, TypeDoc, Property, PropertyVarInstantiation,
MultiLineString, PropertyTestGenerator, ParamDoc
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc, TypeContext,
ClassMemberDoc, ConstructorDoc, ClassDoc, TypeDoc, Property, PropertyBootstrapDoc,
PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc
constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc
constructorToFunctionDoc d =
......@@ -151,7 +158,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
Left _ -> Left e
docBlockToDoc{|OBJECT|} fx doc = appFst (\x -> OBJECT x) <$> fx doc
docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine $ trimMultiLine $ split "\n" s, [])
docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine (trimMultiLine $ split "\n" s), [])
docBlockToDoc{|MultiLineString|} _ = abort "error in docBlockToDoc{|MultiLineString|}\n"
docBlockToDoc{|ParamDoc|} (Left [s]) = case findName (fromString s) of
......@@ -176,6 +183,19 @@ docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map (parseType o fromStri
vs -> Right (last vs, [])
docBlockToDoc{|Type|} _ = abort "error in docBlockToDoc{|Type|}\n"
docBlockToDoc{|PropertyBootstrapDoc|} (Left [s]) = Right
(
{ bootstrap_content = MultiLine (trimMultiLine content)
, bootstrap_without_default_imports = without_imports
}
, []
)
where
lines = split "\n" s
without_imports = hd lines == "without default imports"
content = if without_imports (tl lines) lines
docBlockToDoc{|PropertyBootstrapDoc|} _ = abort "error in docBlockToDoc{|PropertyBootstrapDoc|}\n"
docBlockToDoc{|Property|} (Left [s]) = let [signature:property] = split "\n" s in
parseSignature signature >>= \(sig,ws1) ->
parseProperty property >>= \(prop,ws2) ->
......@@ -186,7 +206,7 @@ where
Left es -> Left (UnknownError "failed to parse property signature")
Right (name,args) -> Right (ForAll name args, [])
where
parser :: Parser Char (!String, ![(!String, !Type)])
parser :: Parser Char (!String, ![(String, Type)])
parser = skipSpaces *>
pMany (pSatisfy ((<>) ':')) >>= \name ->
skipSpaces *> pToken ':' *>
......@@ -230,8 +250,8 @@ where
error = Left (UnknownError "test generator could not be parsed")
docBlockToDoc{|PropertyTestGenerator|} _ = abort "error in docBlockToDoc{|PropertyTestGenerator|}\n"
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ConstructorDoc,
ClassDoc, TypeDoc
derive docBlockToDoc ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ConstructorDoc, ClassDoc, TypeDoc
printDoc :: !d -> String | docToDocBlock{|*|} d
printDoc d = join "\n * "
......@@ -243,29 +263,25 @@ printDoc d = join "\n * "
] +++
"\n */"
where
fields` = case docToDocBlock{|*|} False d of
fields` = case docToDocBlock{|*|} d of
Right fs -> fs
_ -> abort "error in printDoc\n"
fields = filter ((<>) "description" o fst) fields`
desc = lookup "description" fields`
generic docToDocBlock a :: !Bool !a -> Either [String] DocBlock
docToDocBlock{|String|} True s = Left [s]
docToDocBlock{|String|} _ _ = abort "error in docToDocBlock{|String|}\n"
docToDocBlock{|[]|} fx True xs = Left [x \\ Left xs` <- map (fx True) xs, x <- xs`]
docToDocBlock{|[]|} _ _ _ = abort "error in docToDocBlock{|[]|}\n"
docToDocBlock{|Maybe|} fx True mb = case mb of
generic docToDocBlock a :: !a -> Either [String] DocBlock
docToDocBlock{|String|} s = Left [s]
docToDocBlock{|[]|} fx xs = Left [x \\ Left xs` <- map fx xs, x <- xs`]
docToDocBlock{|Maybe|} fx mb = case mb of
Nothing -> Left []
Just x -> fx True x
docToDocBlock{|Maybe|} _ _ _ = abort "error in docToDocBlock{|Maybe|}\n"
Just x -> fx x
docToDocBlock{|PAIR|} fx fy False (PAIR x y) = case fx False x of
Right xs -> case fy False y of
docToDocBlock{|PAIR|} fx fy (PAIR x y) = case fx x of
Right xs -> case fy y of
Right ys -> Right (xs ++ ys)
_ -> abort "error in docToDocBlock{|PAIR|}\n"
_ -> abort "error in docToDocBlock{|PAIR|}\n"
docToDocBlock{|PAIR|} _ _ _ _ = abort "error in docToDocBlock{|PAIR|}\n"
docToDocBlock{|FIELD of d|} fx False (FIELD x) = case fx True x of
docToDocBlock{|FIELD of d|} fx (FIELD x) = case fx x of
Left xs -> Right [(name,x) \\ x <- xs]
_ -> abort "error in docToDocBlock{|FIELD|}\n"
where
......@@ -274,36 +290,31 @@ where
| endsWith "ies" d.gfd_name = d.gfd_name % (0,size d.gfd_name-4) +++ "y"
| endsWith "s" d.gfd_name = d.gfd_name % (0,size d.gfd_name-2)
| otherwise = d.gfd_name
docToDocBlock{|FIELD|} _ _ _ = abort "error in docToDocBlock{|FIELD|}\n"
docToDocBlock{|RECORD|} fx False (RECORD x) = fx False x
docToDocBlock{|RECORD|} _ _ _ = abort "error in docToDocBlock{|RECORD|}\n"
docToDocBlock{|RECORD|} fx (RECORD x) = fx x
docToDocBlock{|ParamDoc|} True pd = case pd.ParamDoc.name of
docToDocBlock{|ParamDoc|} pd = case pd.ParamDoc.name of
Nothing -> case pd.ParamDoc.description of
Nothing -> Left []
Just d -> Left [d]
Just n -> case pd.ParamDoc.description of
Nothing -> Left [n]
Just d -> Left [n +++ ": " +++ d]
docToDocBlock{|ParamDoc|} _ _ = abort "error in docToDocBlock{|ParamDoc|}\n"
docToDocBlock{|MultiLineString|} True (MultiLine s) = Left [s]
docToDocBlock{|MultiLineString|} _ _ = abort "error in docToDocBlock{|MultiLineString|}\n"
docToDocBlock{|Type|} True t = Left [toString t]
docToDocBlock{|Type|} _ _ = abort "error in docToDocBlock{|Type|}\n"
docToDocBlock{|Property|} True (ForAll name args impl) = Left
docToDocBlock{|MultiLineString|} (MultiLine s) = Left [s]
docToDocBlock{|Type|} t = Left [toString t]
docToDocBlock{|PropertyBootstrapDoc|} bs_doc = Left $ [ if bs_doc.bootstrap_without_default_imports " without default imports" ""
: map ((+++) " ") $ split "\n" $ fromMultiLine bs_doc.bootstrap_content
]
docToDocBlock{|Property|} (ForAll name args impl) = Left
[name +++ ": A." +++ join "; " [a +++ " :: " <+ t \\ (a,t) <- args] +++ ":\n" +++ impl]
docToDocBlock{|Property|} _ _ = abort "error in docToDocBlock{|Property|}\n"
docToDocBlock{|PropertyVarInstantiation|} True (PropertyVarInstantiation (a,t)) = Left [a +++ " = " <+ t]
docToDocBlock{|PropertyVarInstantiation|} _ _ = abort "error in docToDocBlock{|PropertyVarInstantiation|}\n"
docToDocBlock{|PropertyTestGenerator|} True ptg = Left [t <+ "\n" +++ imp]
docToDocBlock{|PropertyVarInstantiation|} (PropertyVarInstantiation (a,t)) = Left [a +++ " = " <+ t]
docToDocBlock{|PropertyTestGenerator|} ptg = Left [t <+ "\n" +++ imp]
where
(t,imp) = case ptg of
PTG_Function t imp -> (t,imp)
PTG_List t imp -> (t,imp)
docToDocBlock{|PropertyTestGenerator|} _ _ = abort "error in docToDocBlock{|PropertyTestGenerator|}\n"
derive docToDocBlock ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc,
ConstructorDoc, TypeDoc
derive docToDocBlock ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ClassDoc, ConstructorDoc, TypeDoc
trimMultiLine :: ![String] -> String
trimMultiLine ss = join "\n" [s % (trimn, size s - 1) \\ s <- ss]
......
......@@ -26,15 +26,15 @@ readModule filename w
# (ok,f,w) = fopen filename FReadText w
| not ok = (Error ("Couldn't open " +++ filename), w)
# (mod_id, ht) = putIdentInHashTable modname (IC_Module NoQualifiedIdents) ht
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos True ht stderr) w
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos ht stderr) w
# (ok,w) = fclose f w
| not ok = (Error ("Couldn't close " +++ filename), w)
= (Ok (pm, ht), w)
where
icl = endsWith "icl" filename
wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
wantModule` :: !*File !{#Char} !Bool !Ident !Position !*HashTable !*File !*Files
-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
wantModule` f s b1 i p b2 ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
wantModule` f s b1 i p ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p ht io fs
= ((b1,b2,pm,ht,f),fs)
......@@ -12,13 +12,16 @@ import StdString
import StdTuple
import Control.Monad
import Data.Bifunctor
import Data.Error
from Data.Func import $
import Data.Functor
from Data.Map import :: Map(..), newMap, put, get
from Data.Map import :: Map(..), newMap, put, get, alter
import Data.Maybe
import Data.Tuple
import System.File
import System.FilePath
from Text import class Text(startsWith), instance Text String
from Text import class Text(concat,startsWith), instance Text String
from Heap import :: Heap, :: HeapN, :: Ptr{pointer}, :: PtrN(Ptr), readPtr
from syntax import
......@@ -34,7 +37,7 @@ from syntax import
:: CollectedDefinitions,
:: ComponentNrAndIndex,
:: ConsDef,
:: DclInstanceMemberTypeAndFunction,
:: DclInstanceMemberTypeAndFunctions,
:: Declaration,
:: FileName,
:: FunctionOrMacroIndex,
......@@ -55,7 +58,7 @@ from syntax import
:: ParsedDefinition(..),
:: ParsedExpr,
:: ParsedImport,
:: ParsedInstance{pi_pos},
:: ParsedInstance{pi_ident,pi_pos},
:: ParsedInstanceAndMembers{pim_pi},
:: ParsedModule,
:: ParsedSelector{ps_field_pos,ps_field_ident},
......@@ -97,7 +100,7 @@ scanCommentsFile f
:: ScanState =
{ comment_level :: !Int
, comment_idxs :: ![(!Int,!Int,!Int)] // line, col, idx
, comment_idxs :: ![(Int,Int,Int)] // line, col, idx
, ln :: !Int
, col :: !Int
, input :: !String
......@@ -115,17 +118,20 @@ defaultScanState =
}
advance :: !ScanState -> ScanState
advance ss = {ss & col=ss.col+1, idx=ss.idx+1}
advance ss = case ss.input.[ss.idx] of
'\t' -> {ss & col=ss.col+4, idx=ss.idx+1} // We assume that there are no tabs in a line
'\n' -> {ss & ln=ss.ln+1, col=0, idx=ss.idx+1}
_ -> {ss & col=ss.col+1, idx=ss.idx+1}
scan :: !ScanState -> (![CleanComment], !ScanState)
scan ss=:{idx}
| idx >= size ss.input = ([], ss)
| otherwise = case [ss.input.[i] \\ i <- [idx..]] of
['\r':_]
[s:_] | s=='\r' || s=='\n' || s=='\t'
-> scan (advance ss)
['\n':_]
-> scan {ss & idx=idx+1, ln=ss.ln+1, col=0}
['//':_] | ss.comment_level == 0
['//':_]
| ss.comment_level <> 0
-> scan (scan_to_newline ss)
# cmnt =
{ line = ss.ln
, column = ss.col
......@@ -134,7 +140,9 @@ scan ss=:{idx}
, multiline = False
}
# ss = scan_to_newline ss
# cmnt & content = ss.input % (idx+2,ss.idx-1)
# content = ss.input % (idx+2,ss.idx-1)
# (extra_content,ss) = collect_single_line_comments cmnt.line cmnt.column ss
# cmnt & content = concat [content:extra_content]
# (cmnts,ss) = scan ss
-> ([cmnt:cmnts],ss)
['/*':_]
......@@ -166,13 +174,32 @@ scan ss=:{idx}
-> scan (skip_string_literal '"' (advance ss))
_
-> scan (advance ss)
where
collect_single_line_comments :: !Int !Int !ScanState -> (![String], !ScanState)
collect_single_line_comments ln col ss
# ss=:{idx} = skip_whitespace ss
| ss.ln==ln+1 && ss.col==col
&& ss.idx<size ss.input-2
&& ss.input.[idx]=='/' && ss.input.[idx+1]=='/'
# ss = scan_to_newline ss
# content = ss.input % (idx+2,ss.idx-1)
# (cmnts,ss) = collect_single_line_comments (ln+1) col ss
= ([content:cmnts],ss)
= ([],ss)
scan_to_newline :: !ScanState -> ScanState
scan_to_newline ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
| c == '\n' = {ss & ln=ss.ln+1, col=0, idx=ss.idx+1}
| otherwise = scan_to_newline (advance ss)
# ss = advance ss
= if (c=='\n') ss (scan_to_newline ss)
skip_whitespace :: !ScanState -> ScanState
skip_whitespace ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
| isSpace c = skip_whitespace (advance ss)
| otherwise = ss
skip_list_literal :: !ScanState -> ScanState
skip_list_literal ss
......@@ -215,14 +242,14 @@ where
instance < Position
where
< a b = index a < index b
(<) a b = index a < index b
where
index (FunPos f l n) = (f, l, n)
index (LinePos f l) = (f, l, "")
index (PreDefPos id) = ("", -1, id.id_name)
index NoPos = ("", -2, "")
instance < CommentIndex where < (CI a b c) (CI d e f) = (a,b,c) < (d,e,f)
instance < CommentIndex where (<) (CI a b c) (CI d e f) = (a,b,c) < (d,e,f)
putCC k v coll :== case commentIndex k of
Nothing -> coll
......@@ -245,7 +272,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 +280,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 +298,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 +317,27 @@ 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)
(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) (>=) eq_or_one_less) ln line)
LinePos _ ln -> Just (if multiline (>) (if (singleLineAbove elem) (>=) eq_or_one_less) ln line)
_ -> Nothing
where
eq_or_one_less a b
| column <= 8 // probably meant for the thing a line above
= a==b || a+1==b
= a==b
// 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
......@@ -333,6 +376,8 @@ where
commentIndex pd = case pd of
PD_Function pos id is_infix args rhs kind -> Just (CI "PD_Function" pos id.id_name)
PD_TypeSpec pos id prio type specials -> Just (CI "PD_TypeSpec" pos id.id_name)
PD_Instance {pim_pi=pi} -> Just (CI "PD_Instance" pi.pi_pos pi.pi_ident.id_name)
PD_Instances [{pim_pi=pi}:_] -> Just (CI "PD_Instances" pi.pi_pos pi.pi_ident.id_name)
PD_Class cd pds -> Just (CI "PD_Class" cd.class_pos cd.class_ident.id_name)
PD_Type ptd -> Just (CI "PD_Type" ptd.td_pos ptd.td_ident.id_name)
PD_Generic gd -> Just (CI "PD_Generic" gd.gen_pos gd.gen_ident.id_name)
......
......@@ -14,11 +14,19 @@ where
lookup k [] = k
lookup k [(k`,v):m] = if (k == k`) v (lookup k m)
namemap =
namemap =:
[ ("_Nil", "[]")
, ("_nil", "[|]")
, ("_|Nil", "[|]")
, ("_#Nil", "[#]")
, ("_Nothing", "?^None")
, ("_#Nothing", "?#None")
, ("_!Nothing", "?None")
, ("_|Nothing", "?|None")
, ("_Just", "?^Just")
, ("_#Just", "?#Just")
, ("_!Just", "?Just")
, ("_|Just", "?|Just")
, ("_Unit", "()")
]
......@@ -50,8 +58,8 @@ where
= print st (":: " :+: t :+: ('(',conses,')'))
print st (ID_Record t fields)
= print st (":: " :+: t :+: ('{',fields,'}'))
print st (ID_Instance cls _ (ts, tcs))
= print st (cls :+: join_start st " " ts :+: if (isEmpty tcs) "" (" | " +++ join st " & " tcs))
print st (ID_Instance cls _ ts)
= print st (cls :+: join_start st " " ts)
print st (ID_Generic id _)
= print st ("generic " :+: id)
......
......@@ -47,11 +47,11 @@ where
print st (PD_Function _ id isinfix args rhs fk)
= print stnp (id` :+: join_start stp " " args :+: if show_eq eq "" :+: rhs)
where
stnp = {st & cpp_parens=False}
stp = {st & cpp_parens=True}
stnp = {st & cpp_funkind=fk, cpp_parens=False}
stp = {st & cpp_funkind=fk, cpp_parens=True}
id` = if isinfix ("(" :+: id :+: ")") (id :+: PrintNil)
show_eq = not (compound_rhs rhs.rhs_alts)
eq = case fk of FK_Macro = " :== "; _ = " = "
eq = print st (" " :+: fk :+: " ")
print st (PD_Type {td_ident,td_args,td_attribute,td_rhs})
= print st (":: " :+: td_attribute :+: td_ident :+: join_start st " " td_args :+: equals :+: td_rhs)
where
......@@ -147,14 +147,14 @@ where
= printp st (cv :+: " " :+: join {st & cpp_parens=True} " " ats)
print st (TB bt)
= print st bt
//print st (TFA atvs type)
// = "TFA"
print st (GTV tv)
= print st (tv :+: "^")
print st (TV tv)
= print st tv
print st (TFA atvs type)
= print {st & cpp_parens=False} ("(A." :+: join st " " atvs :+: ": " :+: type :+: ")")
print st (TFAC atvs t tc)
= print st ("(A." :+: join st " " atvs :+: ": " :+: t :+: " | " :+: join st " & " tc :+: ")")
= print {st & cpp_parens=False} ("(A." :+: join st " " atvs :+: ": " :+: t :+: " | " :+: join st " & " tc :+: ")")
print st (TQualifiedIdent id s [])
= print st ("'" :+: id :+: "'." :+: s)
print st (TQualifiedIdent id s ats)
......@@ -212,7 +212,11 @@ where
lookup "_#List!" = Yes ("[#" :+: join stnp " " ats :+: "!]")
lookup "_Array" = Yes ("{" :+: join stnp " " ats :+: "}")
lookup "_#Array" = Yes ("{#" :+: join stnp " " ats :+: "}")
lookup "_32#Array" = Yes ("{32#" :+: join stnp " " ats :+: "}")
lookup "_!Array" = Yes ("{!" :+: join stnp " " ats :+: "}")
lookup "_Maybe" = Yes (if (isEmpty ats) ("(?^)" :+: PrintNil) ("(?^ " :+: join stnp " " ats :+: ")"))
lookup "_!Maybe" = Yes (if (isEmpty ats) ("(?)" :+: PrintNil) ("(? " :+: join stnp " " ats :+: ")"))
lookup "_#Maybe" = Yes (if (isEmpty ats) ("(?#)" :+: PrintNil) ("(?# " :+: join stnp " " ats :+: ")"))
lookup name
| name % (0,5) == "_Tuple"
| length ats == arity = Yes ("(" :+: join stnp "," types :+: ")")
......
definition module Clean.PrettyPrint.Expression
from syntax import :: ParsedExpr, :: Rhs, :: OptGuardedAlts
from syntax import :: ParsedExpr, :: Rhs, :: OptGuardedAlts, :: FunKind
from Clean.PrettyPrint.Util import class print
instance print ParsedExpr, Rhs
instance print ParsedExpr, Rhs, FunKind
/**
* `True` iff the right-hand side is a {{`GuardedAlts`}} or {{`UnguardedExpr`}}
......
......@@ -11,6 +11,14 @@ import Clean.PrettyPrint.Util
import Clean.PrettyPrint.Common
import Clean.PrettyPrint.Definition
instance print FunKind
where
print _ (FK_Function _) = "="
print _ FK_Macro = ":=="
print _ FK_Caf = "=:"
print _ FK_NodeDefOrFunction = "="
print _ FK_Unknown = "="
// General expressions
instance print ParsedExpr
where
......@@ -182,6 +190,7 @@ where
print _ OverloadedArray = ""
print _ StrictArray = "!"
print _ UnboxedArray = "#"
print _ PackedArray = "32#"
instance print ElemAssignment
where
......@@ -218,7 +227,7 @@ where
print st {ewl_expr,ewl_nodes=[],ewl_locals=LocalParsedDefs []}
= print st ewl_expr
print st {ewl_expr,ewl_nodes,ewl_locals=LocalParsedDefs []}
= print st (join_start st` ("\n" :+: st`) ewl_nodes :+: "\n" :+: st` :+: "= " :+: ewl_expr)
= print st (join_start st` ("\n" :+: st`) ewl_nodes :+: "\n" :+: st` :+: st.cpp_funkind :+: " " :+: ewl_expr)
where
st` = {st & cpp_indent = st.cpp_indent + 1}
print st {ewl_expr,ewl_locals}
......
......@@ -8,9 +8,12 @@ definition module Clean.PrettyPrint.Util
from StdOverloaded import class zero, class +++(+++)
:: CPPState
= { cpp_indent :: !Int
from syntax import :: FunKind
:: CPPState =
{ cpp_indent :: !Int
, cpp_parens :: !Bool
, cpp_funkind :: !FunKind
}
:: PrintList
......
......@@ -2,10 +2,14 @@ implementation module Clean.PrettyPrint.Util
import StdEnv
from syntax import :: FunKind(FK_Unknown)
instance zero CPPState
where
zero = { cpp_indent = 0
zero =
{ cpp_indent = 0
, cpp_parens = False
, cpp_funkind = FK_Unknown
}
instance print String where print _ s = s
......
......@@ -5,7 +5,7 @@ definition module Clean.Types
*/
from StdOverloaded import class ==
from StdMaybe import :: Maybe
from Data.Maybe import :: Maybe
/**
* The type of a function.
......@@ -47,7 +47,7 @@ from StdMaybe import :: Maybe
/**
* A type context.
*/
:: TypeContext :== [TypeRestriction]
:: TypeContext =: TypeContext [TypeRestriction]
/**
* A restriction on a type.
......@@ -85,6 +85,7 @@ from StdMaybe import :: Maybe
//* A record with its internal identifier, existentially quantified variables and fields
| TDRSynonym !Type //* A type synonym
| TDRAbstract !(Maybe TypeDefRhs) //* An abstract type
| TDRAbstractNewType !Constructor //* An abstract newtype
| TDRAbstractSynonym !Type //* An abstract type synonym
/**
......@@ -143,7 +144,7 @@ allRestrictions :: !Type -> [TypeRestriction]
/**
* A list of type variables used in a type.
*/
allVars :: (Type -> [TypeVar])
allVars :: !Type -> [TypeVar]
/**
* A list of all the variables that are quantified universally in a (sub)type.
......@@ -259,7 +260,14 @@ constructorsToFunctions :: !TypeDef -> [(String,Type,Maybe Priority)]
* @param The type definition
* @result A list of tuples of the name and type of the record fields
*/
recordsToFunctions :: !TypeDef -> [(String,Type)]
selectorsToFunctions :: !TypeDef -> [(String,Type)]
/**
* Constructor for {{`TypeContext`}}.
*
* @type [TypeRestriction] -> TypeContext
*/
typeContext x :== TypeContext x
/**
* Wrapper around the {{`td_name`}} field of the {{`TypeDef`}} record.
......@@ -276,6 +284,11 @@ td_uniq :: !TypeDef -> Bool
*/
td_rhs :: !TypeDef -> TypeDefRhs
/**
* Make a type strict if it is not strict already.
*/
strict :: !Type -> Type
/**
* Wrapper to create a {{`TypeDef`}} record.
*/
......
......@@ -16,7 +16,7 @@ import Data.Maybe
instance == Type
where
== a b = case a of
(==) a b = case a of
Type t args -> case b of
Type t` args` -> t==t` && args==args`
_ -> False
......@@ -44,7 +44,7 @@ where
instance == TypeRestriction
where
== a b = case a of
(==) a b = case a of
Instance cls ts -> case b of
Instance cls` ts` -> cls==cls` && ts==ts`
_ -> False
......@@ -54,50 +54,69 @@ where
instance == Kind
where
== a b = case a of
(==) a b = case a of
KStar -> b=:KStar
KArrow a b -> case b of
KArrow a` b` -> a==a` && b==b`
_ -> False
instance == TypeContext
where
(==) (TypeContext a) (TypeContext b) = a == b
childTypes :: !Type -> [Type]
childTypes t = case t of
Type _ ts -> ts
Func is r _ -> [r:is]
Cons _ ts -> ts
Uniq t -> [t]
Forall vs t _ -> [t:vs]
Var _ -> []
Arrow mt -> case mt of Just t -> [t]; _ -> []
Strict t -> [t]
subtypes :: !Type -> [Type]
subtypes t=:(Type s ts) = removeDup [t : flatten (map subtypes ts)]
subtypes t=:(Func is r tc) = removeDup [t : flatten (map subtypes [r:is])]
subtypes t=:(Cons c ts) = removeDup [t : flatten (map subtypes ts)]
subtypes t=:(Uniq t`) = removeDup [t : subtypes t`]
subtypes t=:(Forall vs t` tc) = removeDup [t : flatten (map subtypes [t`:vs])]
subtypes t=:(Var _) = [t]
subtypes t=:(Arrow mt) = [t:flatten (map subtypes (maybeToList mt))]
subtypes t=:(Strict t`) = [t:subtypes t`]
subtypes t = subtypes [] [t]
where
subtypes :: ![Type] ![Type] -> [Type]
subtypes subs [] = subs
subtypes subs [type:types]
# subs = if (isMember type subs) subs [type:subs]
= subtypes subs (childTypes type ++ types)
allRestrictions :: !Type -> [TypeRestriction]
allRestrictions (Type _ ts) = concatMap allRestrictions ts
allRestrictions (Func is r tc) = tc ++ concatMap allRestrictions [r:is]
allRestrictions (Func is r (TypeContext tc)) = tc ++ concatMap allRestrictions [r:is]
allRestrictions (Cons _ ts) = concatMap allRestrictions ts
allRestrictions (Uniq t) = allRestrictions t
allRestrictions (Forall _ t tc) = tc ++ allRestrictions t
allRestrictions (Forall _ t (TypeContext tc)) = tc ++ allRestrictions t
allRestrictions (Var _) = []
allRestrictions (Arrow t) = fromMaybe [] (allRestrictions <$> t)
allRestrictions (Strict t) = allRestrictions t
allVars :: (Type -> [TypeVar])
allVars = removeDup o map name o filter (\t -> isCons t || isVar t) o subtypes
allVars :: !Type -> [TypeVar]
allVars t = vars [] [t]
where
name :: !Type -> TypeVar
name (Cons v _) = v
name (Var v) = v
name _ = abort "error in allVars\n"
vars :: ![TypeVar] ![Type] -> [TypeVar]
vars vs [] = vs
vars vs [type:types]
# vs = case type of
Cons c _ -> if (isMember c vs) vs [c:vs]
Var v -> if (isMember v vs) vs [v:vs]
_ -> vs
= vars vs (childTypes type ++ types)
allUniversalVars :: !Type -> [TypeVar]
allUniversalVars (Forall vs t tc) = removeDup (flatten (map allVars vs) ++ allUniversalVars t)
allUniversalVars (Type _ ts) = removeDup (flatten (map allUniversalVars ts))
allUniversalVars (Func is r _) = removeDup (flatten