...
 
Commits (504)
Clean System Files
*.abc
*.bc
*.o
*.tcl
*.prj
*.prp
*.exe
a.out
* Time Profile.pcl
_Tests
_Tests.*
test:
test-nightly:
before_script:
- install_clean.sh bundle-complete
- apt-get update -qq
- apt-get install -y -qq build-essential git coreutils libsnappy-dev
- git clone --recursive https://gitlab.science.ru.nl/clean-and-itasks/clean-test-properties /opt/clean-test-properties
- make -C /opt/clean-test-properties/src -f Makefile.linux64
- apt-get install -y -qq build-essential git coreutils libmariadb-dev librdkafka-dev libsnappy-dev libsqlite3-dev
- make -C src/cdeps install
- 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
- stdbuf -o0 -e0 /opt/clean-test-properties/src/testproperties -IL Dynamics -d src/libraries/OS-Independent -P Quiet -r -T 'Tests 100000' -C -h -C 100m
- 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
......
......@@ -96,7 +96,9 @@ collisions, adhere to the following conventions:
Implementation modules may import anything they like.
## Implementing class instances and generic derives
## 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`
- [ ] ...
......
CC=gcc
OBJS:=systemsignal.o
all: $(OBJS)
install: $(OBJS)
mkdir -p ../libraries/OS-Independent/Clean\ System\ Files/
cp -v $(OBJS) ../libraries/OS-Independent/Clean\ System\ Files/
#include <stdlib.h>
#include <signal.h>
static long signal_state[NSIG] = {0};
#ifdef _WIN32
static void signal_handler(int sig)
{
#else
static void signal_handler(int sig, siginfo_t *si, void *unused)
{
(void)si;
(void)unused;
#endif
signal_state[sig] = 1;
}
void signal_install(long signum, long *ok, long *handler)
{
#ifdef _WIN32
*ok = signal(signum, signal_handler) == SIG_ERR;
#else
struct sigaction act;
act.sa_flags = SA_SIGINFO;
sigemptyset(&act.sa_mask);
act.sa_sigaction = signal_handler;
*ok = sigaction(signum, &act, NULL);
#endif
*handler = signum;
}
void signal_poll(long handler, long *ok, long *state, long *handlerr)
{
*ok = 1;
if(0 < handler && handler < NSIG){
*handlerr = handler;
*state = signal_state[handler];
signal_state[handler] = 0;
*ok = 0;
}
}
int signal_ignore(long signum)
{
return signal(signum, SIG_IGN) == SIG_ERR;
}
module client
import StdEnv
import Data.Error
import Data.Maybe
import Network.IP
import System.Socket
import System.Socket.Ipv4
Start :: *World -> (MaybeOSError String, *World)
Start w
= case socket SocketStream w of
(Error e, w) = (Error e, w)
(Ok sockfd, w)
#! (merr, sockfd) = connect {ipv4_socket_port=8124,ipv4_socket_addr=Just (fromString "127.0.0.1")} sockfd
| isError merr = (liftError merr, w)
#! (merr, sockfd) = recv 128 [] sockfd
| isError merr = (merr, w)
# (Ok msg) = merr
# (merr, w) = close sockfd w
| isError merr = (liftError merr, w)
= (Ok msg, w)
module server
import StdDebug
import StdEnv
import Data.Error
import Data.Maybe
import System.Socket
import System.Socket.Ipv4
Start :: *World -> (MaybeOSError (), *World)
Start w
= case socket SocketStream w of
(Error e, w) = (Error e, w)
(Ok sockfd, w)
#! (merr, sockfd) = bind {ipv4_socket_port=8124,ipv4_socket_addr=Nothing} sockfd
| isError merr = (merr, w)
#! (merr, sockfd) = listen 3 sockfd
| isError merr = (merr, w)
= case accept sockfd of
(Error e, sockfd) = (Error e, w)
(Ok (sock, addr), sockfd)
# (merr, sock) = send "Hello world!" [] sock
| isError merr = (liftError merr, w)
# (merr, w) = close sock w
| isError merr = (merr, w)
# (merr, w) = close sockfd w
| isError merr = (merr, w)
= (Ok (), w)
#include <stdio.h>
#include <stddef.h>
#ifdef _WIN32
#include <winsock2.h>
#include <ws2tcpip.h>
#else
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <sys/un.h>
#endif
int main(void)
{
printf("AF_INET :== %lu\n", AF_INET);
#ifdef linux
printf("AF_UNIX :== %lu\n", AF_UNIX);
#endif
printf("AF_INET6 :== %lu\n", AF_INET6);
printf("AF_IPX :== %lu\n", AF_IPX);
printf("AF_APPLETALK :== %lu\n", AF_APPLETALK);
printf("AF_IRDA :== %lu\n", AF_IRDA);
printf("SOCK_STREAM :== %lu\n", SOCK_STREAM);
printf("SOCK_DGRAM :== %lu\n", SOCK_DGRAM);
printf("MSG_DONTROUTE :== %lu\n", MSG_DONTROUTE);
printf("MSG_OOB :== %lu\n", MSG_OOB);
printf("MSG_PEEK :== %lu\n", MSG_PEEK);
printf("MSG_WAITALL :== %lu\n", MSG_WAITALL);
printf("\nsockaddr_in offsets:\n");
printf("sin_family: %lu\n", offsetof(struct sockaddr_in, sin_family));
printf("sin_port: %lu\n", offsetof(struct sockaddr_in, sin_port));
printf("sin_addr: %lu\n", offsetof(struct sockaddr_in, sin_addr));
printf("in_addr offsets:\n");
printf("s_addr: %lu\n", offsetof(struct in_addr, s_addr));
#ifdef linux
printf("\nsockaddr_un offsets:\n");
printf("sun_family: %lu\n", offsetof(struct sockaddr_un, sun_family));
printf("sun_path: %lu\n", offsetof(struct sockaddr_un, sun_path));
#endif
printf("\nsockaddr_in6 offsets:\n");
printf("sin6_family: %lu\n",
offsetof(struct sockaddr_in6, sin6_family));
printf("sin6_port: %lu\n", offsetof(struct sockaddr_in6, sin6_port));
printf("sin6_flowinfo: %lu\n",
offsetof(struct sockaddr_in6, sin6_flowinfo));
printf("sin6_addr: %lu\n", offsetof(struct sockaddr_in6, sin6_addr));
printf("sin6_scope_id: %lu\n",
offsetof(struct sockaddr_in6, sin6_scope_id));
printf("in6_addr offsets:\n");
printf("s6_addr: %lu\n", offsetof(struct in6_addr, s6_addr));
#ifdef _WIN32
printf("sizeof(WSADATA): %lu\n", sizeof(WSADATA));
#endif
return 0;
}
This diff is collapsed.
This diff is collapsed.
......@@ -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,20 +14,28 @@ where
lookup k [] = k
lookup k [(k`,v):m] = if (k == k`) v (lookup k m)
namemap =
[ ("_Nil", "[]")
, ("_nil", "[|]")
, ("_|Nil", "[|]")
, ("_#Nil", "[#]")
, ("_Unit", "()")
]
namemap =:
[ ("_Nil", "[]")
, ("_nil", "[|]")
, ("_|Nil", "[|]")
, ("_#Nil", "[#]")
, ("_Nothing", "?^None")
, ("_#Nothing", "?#None")
, ("_!Nothing", "?None")
, ("_|Nothing", "?|None")
, ("_Just", "?^Just")
, ("_#Just", "?#Just")
, ("_!Just", "?Just")
, ("_|Just", "?|Just")
, ("_Unit", "()")
]
instance print Import
where
print st ip=:{import_symbols=ImportSymbolsOnly ids,import_qualified=NotQualified}
= print st ("from " :+: ip.import_module :+: " import " :+: join st ", " ids)
print st ip=:{import_symbols=ImportSymbolsOnly _}
= abort "UNKNOWN: ImportSymbolsOnly with Qualified"
= abort "UNKNOWN: ImportSymbolsOnly with Qualified\n"
print st ip=:{import_symbols=ImportSymbolsAll}
= print st ("import " :+: q :+: ip.import_module :+: as_)
where
......@@ -37,33 +45,32 @@ where
as_ = case ip.import_qualified of
(QualifiedAs name) = " as " :+: name
_ = PrintNil
print st ip=:{import_symbols=ImportSymbolsAllSomeQualified _}
= abort "UNKNOWN: ImportSymbolsAllSomeQualified\n"
instance print ImportDeclaration
where
print st (ID_Function f)
= print st f
print st (ID_Class c mems)
= print st ("class " :+: c :+: mems`)
where
mems` = case mems of
(Yes []) = "(..)"
(Yes mems) = "(" +++ join st "," mems +++ ")"
_ = ""
= print st ("class " :+: c :+: ('(',mems,')'))
print st (ID_Type t conses)
= print st (":: " :+: t :+: conses`)
where
conses` = case conses of
(Yes []) = "(..)"
(Yes conses) = "(" +++ join st "," conses +++ ")"
_ = ""
= print st (":: " :+: t :+: ('(',conses,')'))
print st (ID_Record t fields)
= print st (":: " :+: t :+: fields`)
where
fields` = case fields of
(Yes []) = "{..}"
(Yes fields) = "{" +++ join st "," fields +++ "}"
_ = ""
print st (ID_Instance cls _ (ts, tcs))
= print st (cls :+: join_start st " " ts :+: if (isEmpty tcs) "" (" | " +++ join st " & " tcs))
= print st (":: " :+: t :+: ('{',fields,'}'))
print st (ID_Instance cls _ ts)
= print st (cls :+: join_start st " " ts)
print st (ID_Generic id _)
= print st ("generic " :+: id)
instance print (Char, ImportBelongings, Char)
where
print st (_,IB_None,_) = ""
print st (open,IB_Idents [],close) = {#open,'.','.',close}
print st (open,IB_Idents is,close) = print st ({#open} :+: join st "," is :+: {#close})
print st (open,IB_IdentsAndOptIdents is opts,close) =
print st ({#open} :+: join st ","
[print st (i :+: if addparens "()" "")
\\ i <- is++opts
& addparens <- repeatn (length is) False++repeat True]
:+: {#close})
......@@ -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)
......@@ -162,9 +162,12 @@ where
//| TGenericFunctionInDictionary !(Global DefinedSymbol) !TypeKind !GlobalIndex /*GenericDict*/
//| TE
print st _
= abort "UNKNOWN_TYPE"
= abort "UNKNOWN Type\n"
instance print ConsVariable where print st (CV tv) = print st tv //TODO
instance print ConsVariable
where
print st (CV tv) = print st tv
print st _ = abort "UNKNOWN ConsVariable\n"
instance print TypeVar where print st {tv_ident} = tv_ident.id_name
......@@ -202,14 +205,18 @@ where
lookup "_!List" = Yes ("[!" :+: join stnp " " ats :+: "]")
lookup "_List!"
| isEmpty ats = Yes ("[ !]" :+: PrintNil)
| otherwise = Yes ("[" :+: join stnp " " ats :+: "!]")
lookup "_!List!" = Yes ("[!" :+: join stnp " " ats :+: "!]")
lookup "_|List" = Yes ("[|" :+: join stnp " " ats :+: "]")
lookup "_#List" = Yes ("[#" :+: join stnp " " ats :+: "]")
lookup "_#List!" = Yes ("[#" :+: join stnp " " ats :+: "!]")
lookup "_Array" = Yes ("{" :+: join stnp " " ats :+: "}")
lookup "_#Array" = Yes ("{#" :+: join stnp " " ats :+: "}")
lookup "_!Array" = Yes ("{!" :+: join stnp " " ats :+: "}")
| otherwise = Yes ("[" :+: join stnp " " ats :+: "!]")
lookup "_!List!" = Yes ("[!" :+: join stnp " " ats :+: "!]")
lookup "_|List" = Yes ("[|" :+: join stnp " " ats :+: "]")
lookup "_#List" = Yes ("[#" :+: join stnp " " ats :+: "]")
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 :+: ")")
......@@ -283,8 +290,8 @@ where
= print st ds_ident
print st (TCGeneric {gtc_generic,gtc_kind})
= print st (gtc_generic.glob_object.ds_ident.id_name :+: "{|" :+: gtc_kind :+: "|}")
print st _
= abort "UNKNOWN_TCCLASS"
print st (TCQualifiedIdent id name)
= print st ("'" :+: id :+: "'." :+: name)
instance print ParsedInstanceAndMembers
where
......@@ -312,6 +319,7 @@ instance print TypeKind
where
print st KindConst = print st "*"
print st (KindArrow ks) = print st ("*->" :+: ks)
print st _ = abort "UNKNOWN TypeKind\n"
// Uniqueness
instance print AttrInequality
......
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,10 +8,13 @@ definition module Clean.PrettyPrint.Util
from StdOverloaded import class zero, class +++(+++)
:: CPPState
= { cpp_indent :: !Int
, cpp_parens :: !Bool
}
from syntax import :: FunKind
:: CPPState =
{ cpp_indent :: !Int
, cpp_parens :: !Bool
, cpp_funkind :: !FunKind
}
:: PrintList
= PrintNil
......
......@@ -2,11 +2,15 @@ implementation module Clean.PrettyPrint.Util
import StdEnv
from syntax import :: FunKind(FK_Unknown)
instance zero CPPState
where
zero = { cpp_indent = 0
, cpp_parens = False
}
zero =
{ cpp_indent = 0
, cpp_parens = False
, cpp_funkind = FK_Unknown
}
instance print String where print _ s = s
instance print Int where print _ i = toString i
......
......@@ -5,20 +5,19 @@ definition module Clean.Types
*/
from StdOverloaded import class ==
from Data.Maybe import :: Maybe
/**
* The type of a function.
*/
:: Type
= Type String [Type] //* Concrete type with arguments
| Func [Type] Type TypeContext //* A function with parameters, a result and class context (no uniqueness unequalities yet)
| Var TypeVar //* A type variable
| 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)`
| Strict Type //* A type annotated for strictness
= Type !String ![Type] //* Concrete type with arguments
| Func ![Type] !Type !TypeContext //* A function with parameters, a result and class context (no uniqueness inequalities yet)
| Var !TypeVar //* A type variable
| Cons !TypeVar ![Type] //* A constructor variable with arguments
| Uniq !Type //* A unique type
| Forall ![Type] !Type !TypeContext //* Universally quantified variables
| Arrow !(?Type) //* `(->)` and `((->) t)`
| Strict !Type //* A type annotated for strictness
/**
* A type variable.
......@@ -30,92 +29,92 @@ from Data.Maybe import :: Maybe
* An assignment of a type to a type variable.
* @representation A tuple of the variable and the type
*/
:: TVAssignment :== (TypeVar, Type)
:: TVAssignment :== (!TypeVar, !Type)
/**
* A unifier of a left type and a right type.
*/
:: Unifier
= { assignments :: [UnifyingAssignment] //* The assignments
, used_synonyms :: [TypeDef] //* Type synonyms used in the unification
= { assignments :: ![UnifyingAssignment] //* The assignments
, used_synonyms :: ![TypeDef] //* Type synonyms used in the unification
}
:: UnifyingAssignment
= RightToLeft TVAssignment
| LeftToRight TVAssignment
= RightToLeft !TVAssignment
| LeftToRight !TVAssignment
/**
* A type context.
*/
:: TypeContext :== [TypeRestriction]
:: TypeContext =: TypeContext [TypeRestriction]
/**
* A restriction on a type.
*/
:: TypeRestriction
= Instance String [Type]
| Derivation String Type
= Instance !String ![Type]
| Derivation !String !Type
/**
* The kind of a Clean type.
*/
:: Kind
= KStar
| KArrow infixr 1 Kind Kind
| KArrow infixr 1 !Kind !Kind
/**
* A Clean type definition.
*/
:: TypeDef
= { td_name :: String //* The name of the type
, td_uniq :: Bool //* Whether the type is unique
, td_args :: [Type] //* Var or Uniq Var; arguments
, td_rhs :: TypeDefRhs //* The right-hand side
= { td_name :: !String //* The name of the type
, td_uniq :: !Bool //* Whether the type is unique
, td_args :: ![Type] //* Var or Uniq Var; arguments
, td_rhs :: !TypeDefRhs //* The right-hand side
}
/**
* The right-hand side of a type definition.
*/
:: TypeDefRhs
= TDRCons Bool [Constructor]
= TDRCons !Bool ![Constructor]
//* A list of constructors. The boolean indicates if the type is extensible
| TDRNewType Constructor //* A newtype
| TDRMoreConses [Constructor] //* More constructors for an extensible ADT
| TDRRecord String [TypeVar] [RecordField]
| TDRNewType !Constructor //* A newtype
| TDRMoreConses ![Constructor] //* More constructors for an extensible ADT
| 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
| TDRAbstractSynonym Type //* An abstract type synonym
| TDRSynonym !Type //* A type synonym
| TDRAbstract !(?TypeDefRhs) //* An abstract type
| TDRAbstractNewType !Constructor //* An abstract newtype
| TDRAbstractSynonym !Type //* An abstract type synonym
/**
* The constructor of an algebraic data type.
*/
:: Constructor
= { cons_name :: String //* The name of the constructor
, 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_name :: !String //* The name of the constructor
, 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 :: !?Priority //* Priority, if this is an infix constructor
}
/**
* Priority of an infix function.
*/
:: Priority
= LeftAssoc Int //* Left-associative operator with precedence
| RightAssoc Int //* Right-associative operator with precedence
| NoAssoc Int //* Infix operator with precedence but no explicit associativity
= LeftAssoc !Int //* Left-associative operator with precedence
| RightAssoc !Int //* Right-associative operator with precedence
| NoAssoc !Int //* Infix operator with precedence but no explicit associativity
/**
* A record field.
*/
:: RecordField
= { rf_name :: String //* The name of the field
, rf_type :: Type //* The type of the field
= { rf_name :: !String //* The name of the field
, rf_type :: !Type //* The type of the field
}
instance == Type
instance == TypeRestriction
instance == Type, TypeRestriction, Kind
class toType a :: !a -> Type
class toTypeVar a :: !a -> TypeVar
......@@ -125,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
/**
......@@ -144,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.
......@@ -227,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`}}.
......@@ -252,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.
......@@ -260,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.
......@@ -277,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.
*/
......@@ -285,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.
......