...
 
Commits (315)
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.*
test-nightly:
image: camilstaps/clean:nightly
linux-x64:
before_script:
- install_clean.sh bundle-complete
- apt-get update -qq
- apt-get install -y -qq build-essential git coreutils libsnappy-dev
- apt-get install -y -qq build-essential git coreutils libmariadb-dev librdkafka-dev libsnappy-dev libsqlite3-dev
- make -C src/cdeps install
image: "camilstaps/clean:nightly"
- git clone https://gitlab.science.ru.nl/clean-compiler-and-rts/compiler tests/common/compiler
- make -C tests/common/compiler/main/Unix
- make -j -C tests/common/compiler/backendC/CleanCompilerSources -f Makefile.linux64
- mkdir -p tests/common/compiler/backend/Clean\ System\ Files
- ln -fs ../../backendC/CleanCompilerSources/backend.a tests/common/compiler/backend/Clean\ System\ Files/backend_library
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
- make -C tests imports_common imports_posix imports_linux imports_linux_64 imports_x86
- COCLPATH=./compiler make -C tests/common 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
test-stable:
linux-x86:
before_script:
- CLEAN_PLATFORM=x86 install_clean.sh bundle-complete
- 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"
image: "camilstaps/clean:nightly"
- apt-get install -y -qq build-essential git coreutils libmariadb-dev:i386 librdkafka-dev:i386 libsnappy-dev:i386 libsqlite3-dev:i386
- CFLAGS=-m32 make -C src/cdeps install
- git clone https://gitlab.science.ru.nl/clean-compiler-and-rts/compiler tests/common/compiler
- make -C tests/common/compiler/main/Unix
- make -j -C tests/common/compiler/backendC/CleanCompilerSources
- mkdir -p tests/common/compiler/backend/Clean\ System\ Files
- ln -fs ../../backendC/CleanCompilerSources/backend.a tests/common/compiler/backend/Clean\ System\ Files/backend_library
script:
- make -C tests/linux64 run
allow_failure: true
- COLLECTIONS='OS-Posix OS-Linux OS-Linux-32 Platform-x86' make -C tests imports_common imports_posix imports_linux imports_linux_32 imports_x86
- COCLPATH=./compiler make -C tests/common 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;
}
......@@ -9,7 +9,6 @@ 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
......@@ -17,31 +16,32 @@ 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
class docDescription d :: !d -> ?Description
class docComplexity d :: !d -> ?String
class docParams d :: !d -> [ParamDoc]
class docVars d :: !d -> [Description]
class docResults d :: !d -> [Description]
class docType d :: !d -> Maybe Type
class docType d :: !d -> ?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 docMembers d :: !d -> [?ClassMemberDoc]
class docFields d :: !d -> ?[?Description]
class docConstructors d :: !d -> ?[?ConstructorDoc]
class docRepresentation d :: !d -> ?(?Description)
class docPropertyBootstrap d :: !d -> Maybe String
class docPropertyBootstrap d :: !d -> ?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
{ description :: !?Description
, property_bootstrap :: !?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,18 +51,25 @@ 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.
*/
:: FunctionDoc =
{ description :: !Maybe Description
, complexity :: !Maybe String //* E.g. "O(n log n)"
{ description :: !?Description
, complexity :: !?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)
, type :: !?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
......@@ -76,15 +83,33 @@ 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 :: !?Description
, complexity :: !?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.
*/
:: ParamDoc =
{ name :: !Maybe String //* An optional name for the parameter
, description :: !Maybe Description //* An optional description
{ name :: !?String //* An optional name for the parameter
, description :: !?Description //* An optional description
}
instance toString ParamDoc
......@@ -98,7 +123,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,18 +148,18 @@ 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.
* For an explanation of the fields, see the documentation on {{`FunctionDoc`}}.
*/
:: ClassMemberDoc =
{ description :: !Maybe Description
, complexity :: !Maybe String
{ description :: !?Description
, complexity :: !?String
, params :: ![ParamDoc]
, results :: ![Description]
, type :: !Maybe Type
, type :: !?Type
, throws :: ![Description]
}
......@@ -151,7 +176,7 @@ derive gDefault ClassMemberDoc
* For an explanation of the fields, see the documentation on {{`FunctionDoc`}}.
*/
:: ConstructorDoc =
{ description :: !Maybe Description
{ description :: !?Description
, params :: ![ParamDoc]
}
......@@ -163,9 +188,9 @@ derive gDefault ConstructorDoc
* Documentation of a Clean class.
*/
:: ClassDoc =
{ description :: !Maybe Description
{ description :: !?Description
, vars :: ![Description] //* The type variables
, members :: ![Maybe ClassMemberDoc] //* Documentation on the members
, members :: ![?ClassMemberDoc] //* Documentation on the members
}
instance docDescription ClassDoc
......@@ -177,11 +202,11 @@ derive gDefault ClassDoc
* Documentation of a Clean type.
*/
:: TypeDoc =
{ description :: !Maybe Description
{ description :: !?Description
, vars :: ![Description] //* Type variables
, representation :: !Maybe (Maybe Description) //* For synonym types
, fields :: !Maybe [Maybe Description] //* For records
, constructors :: !Maybe [Maybe ConstructorDoc] //* For ADTs
, representation :: !?(?Description) //* For synonym types
, fields :: !?[?Description] //* For records
, constructors :: !?[?ConstructorDoc] //* For ADTs
, invariants :: ![Property] //* For Gast test generation
}
......@@ -234,7 +259,7 @@ functionToClassMemberDoc :: !FunctionDoc -> ClassMemberDoc
* @param The documentation on the class member
* @result The new ClassDoc
*/
addClassMemberDoc :: !ClassDoc !(Maybe ClassMemberDoc) -> ClassDoc
addClassMemberDoc :: !ClassDoc !(?ClassMemberDoc) -> ClassDoc
/**
* Parse a single docstring, removing the asterisk and trimming whitespace.
......@@ -251,7 +276,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`}}
......@@ -263,9 +288,9 @@ parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|
generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ![ParseWarning])
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 String, [], ?, Type
derive docBlockToDoc ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ClassDoc, ConstructorDoc, TypeDoc
/**
* Print a documentation block as a string. The magic happens in
......@@ -275,12 +300,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
......
This diff is collapsed.
......@@ -7,6 +7,7 @@ import StdString
import Clean.Parse.ModuleName
import Data.Error
from Data.Func import $, mapSt
import Data.Maybe
import System.Directory
import System.Environment
import System.File
......@@ -77,7 +78,7 @@ where
# (modname, w) = guessModuleName fp w
| isError modname = (seen, w)
# modname = fromOk modname
| isNothing modname = (seen, w)
| isNone modname = (seen, w)
# modname = fromJust modname
# expected = {if (c == pathSeparator) '.' c \\ c <-: fp % (size dir`, size fp - 5)}
with dir` = dir </> ""
......
......@@ -6,7 +6,6 @@ definition module Clean.Parse
*/
from Data.Error import :: MaybeError
from Data.Maybe import :: Maybe
from System.FilePath import :: FilePath
from hashtable import :: HashTable
......
......@@ -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)
......@@ -9,7 +9,6 @@ definition module Clean.Parse.Comments
from StdFile import class FileSystem
from Data.Error import :: MaybeError
from Data.Maybe import :: Maybe
from System.File import :: FileError
from System.FilePath import :: FilePath
......@@ -22,7 +21,7 @@ from syntax import :: Ident, :: Module, :: ParsedConstructor,
:: CleanComment =
{ line :: !Int
, column :: !Int
, level :: !Maybe Int //* Nothing for single-line comments, otherwise the nesting level
, level :: !?Int //* `?None` for single-line comments, otherwise the nesting level
, content :: !String //* All content except `//` or `/*` and `*/`
, multiline :: !Bool
}
......@@ -52,9 +51,9 @@ emptyCollectedComments :: CollectedComments
/**
* Get the comment content for an identifier.
*/
getComment :: !a !CollectedComments -> Maybe String | commentIndex a
getComment :: !a !CollectedComments -> ?String | commentIndex a
class commentIndex a :: !a -> Maybe CommentIndex
class commentIndex a :: !a -> ?CommentIndex
instance commentIndex (Module a), ParsedDefinition, ParsedSelector, ParsedConstructor
/**
......
definition module Clean.Parse.ModuleName
from Data.Error import :: MaybeError
from Data.Maybe import :: Maybe
from System.File import :: FileError
from System.FilePath import :: FilePath
......@@ -11,7 +10,7 @@ from System.FilePath import :: FilePath
* @param The path to the Clean file
* @result
* `Error`, if the file could not be read;
* `Ok Nothing`, if the module name could not be guessed;
* `Ok (Just name)` in case of success.
* `Ok ?None, if the module name could not be guessed;
* `Ok (?Just name)` in case of success.
*/
guessModuleName :: !FilePath !*World -> *(!MaybeError FileError (Maybe String), !*World)
guessModuleName :: !FilePath !*World -> *(!MaybeError FileError (?String), !*World)
......@@ -7,11 +7,10 @@ import StdFile
import StdList
import Data.Error
import Data.Maybe
import System.File
import System.FilePath
guessModuleName :: !FilePath !*World -> *(!MaybeError FileError (Maybe String), !*World)
guessModuleName :: !FilePath !*World -> *(!MaybeError FileError (?String), !*World)
guessModuleName filename w
# (s,w) = readFile filename w
| isError s = (Error (fromError s), w)
......@@ -20,7 +19,7 @@ guessModuleName filename w
// A reasonably accurate simple scanner to get the module name from the file
getModuleName :: ![Char] -> Maybe String
getModuleName :: ![Char] -> ?String
getModuleName ['definition':c:cs] | isSpace c = justModule cs
getModuleName ['implementation':c:cs] | isSpace c = justModule cs
getModuleName ['system':c:cs] | isSpace c = justModule cs
......@@ -29,20 +28,20 @@ getModuleName ['//':cs] = getModuleName (dropWhile ((<
getModuleName ['/*':cs] = getModuleName (skipMultiLineComment cs)
getModuleName cs = justModule cs
justModule :: ![Char] -> Maybe String
justModule :: ![Char] -> ?String
justModule ['module':c:cs] | isSpace c = justModuleName cs
justModule [c:cs] | isSpace c = justModule cs
justModule ['//':cs] = justModule (dropWhile ((<>) '\n') cs)
justModule ['/*':cs] = justModule (skipMultiLineComment cs)
justModule _ = Nothing
justModule _ = ?None
justModuleName :: ![Char] -> Maybe String
justModuleName :: ![Char] -> ?String
justModuleName cs
# (_,cs) = span isSpace cs
# (name,_) = span (\c -> c <> '/' && c <> ';' && not (isSpace c)) cs
= case name of
[] -> Nothing
_ -> Just (toString name)
[] -> ?None
_ -> ?Just (toString name)
skipMultiLineComment :: ![Char] -> [Char]
skipMultiLineComment ['*/':cs] = cs
......
......@@ -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,6 @@ definition module Clean.Types
*/
from StdOverloaded import class ==
from StdMaybe import :: Maybe
/**
* The type of a function.
......@@ -17,7 +16,7 @@ from StdMaybe import :: Maybe
| Cons !TypeVar ![Type] //* A constructor variable with arguments
| Uniq !Type //* A unique type
| Forall ![Type] !Type !TypeContext //* Universally quantified variables
| Arrow !(Maybe Type) //* `(->)` and `((->) t)`
| Arrow !(?Type) //* `(->)` and `((->) t)`
| Strict !Type //* A type annotated for strictness
/**
......@@ -47,7 +46,7 @@ from StdMaybe import :: Maybe
/**
* A type context.
*/
:: TypeContext :== [TypeRestriction]
:: TypeContext =: TypeContext [TypeRestriction]
/**
* A restriction on a type.
......@@ -84,7 +83,8 @@ from StdMaybe import :: Maybe
| TDRRecord !String ![TypeVar] ![RecordField]
//* A record with its internal identifier, existentially quantified variables and fields
| TDRSynonym !Type //* A type synonym
| TDRAbstract !(Maybe TypeDefRhs) //* An abstract type
| TDRAbstract !(?TypeDefRhs) //* An abstract type
| TDRAbstractNewType !Constructor //* An abstract newtype
| TDRAbstractSynonym !Type //* An abstract type synonym
/**
......@@ -95,7 +95,7 @@ from StdMaybe import :: Maybe
, cons_args :: ![Type] //* The arguments of the constructor
, cons_exi_vars :: ![TypeVar] //* Existentially quantified variables
, cons_context :: !TypeContext //* The class context of the constructor
, cons_priority :: !Maybe Priority //* Priority, if this is an infix constructor
, cons_priority :: !?Priority //* Priority, if this is an infix constructor
}
/**
......@@ -124,7 +124,7 @@ class toTypeContext a :: !a -> TypeContext
class toTypeDef a :: !a -> TypeDef
class toTypeDefRhs a :: !a -> TypeDefRhs
class toConstructor a :: !a -> Constructor
class toMaybePriority a :: !a -> Maybe Priority
class toMaybePriority a :: !a -> ?Priority
class toRecordField a :: !a -> RecordField
/**
......@@ -143,7 +143,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.
......@@ -226,7 +226,13 @@ isArrow :: !Type -> Bool
* Remove the `Arrow` constructor from a type.
* Generates a run-time error if the type is of another constructor.
*/
fromArrow :: !Type -> Maybe Type
fromArrow :: !Type -> ?Type
/**
* Remove the `Strict` constructor from a type.
* Generates a run-time error if the type is of another constructor.
*/
fromStrict :: !Type -> Type
/**
* Get the {{`TVAssignment`}} from a {{`UnifyingAssignment`}}.
......@@ -251,7 +257,7 @@ removeTypeContexts :: !Type -> Type
* @param The type definition
* @result A list of tuples of the name, type and infix priority of the constructors
*/
constructorsToFunctions :: !TypeDef -> [(String,Type,Maybe Priority)]
constructorsToFunctions :: !TypeDef -> [(String,Type,?Priority)]
/**
* The record fields of an algebraic data type, as functions.
......@@ -259,7 +265,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 +289,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.
*/
......@@ -284,7 +302,7 @@ typedef :: !String !Bool ![Type] !TypeDefRhs -> TypeDef
/**
* Wrapper to create a {{`Constructor`}} record.
*/
constructor :: !String ![Type] ![TypeVar] !TypeContext !(Maybe Priority) -> Constructor
constructor :: !String ![Type] ![TypeVar] !TypeContext !(?Priority) -> Constructor
/**
* Wrapper to create a {{`RecordField`}} 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 (map allUniversalVars [r:is]))
allUniversalVars (Cons _ ts) = removeDup (flatten (map allUniversalVars ts))
allUniversalVars (Uniq t) = allUniversalVars t
allUniversalVars (Var _) = []
allUniversalVars (Arrow (Just t)) = allUniversalVars t
allUniversalVars (Arrow Nothing) = []
allUniversalVars (Strict t) = allUniversalVars t
allUniversalVars t = vars [] [t]
where
vars :: ![TypeVar] ![Type] -> [TypeVar]
vars vs [] = vs
vars vs [type:types]
# vs = case type of
Forall newvs _ _
-> foldl (\vs v -> if (isMember v vs) vs [v:vs]) vs (concatMap allVars newvs)
-> vs
= vars vs (childTypes type ++ types)
isVar :: !Type -> Bool
isVar t = t=:(Var _)
......@@ -150,11 +169,16 @@ fromForall t = case t of
isArrow :: !Type -> Bool
isArrow t = t=:(Arrow _)