...
 
Commits (115)
......@@ -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 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 -j -C tests/linux64/compiler/main/Unix
- make -j -C tests/linux64/compiler/backendC/CleanCompilerSources -f Makefile.linux64
- mkdir -p tests/linux64/compiler/backend/Clean\ System\ Files
- ln -fs ../../backendC/CleanCompilerSources/backend.a tests/linux64/compiler/backend/Clean\ System\ Files/backend_library
image: "camilstaps/clean:nightly"
script:
- make -C tests/linux64 run
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
......
......@@ -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`
- [ ] ...
......
......@@ -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;
}
......@@ -35,6 +35,7 @@ class docPropertyBootstrap d :: !d -> Maybe String
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.
......@@ -76,8 +77,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 +117,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 +142,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 +270,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 +283,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
......@@ -279,8 +298,8 @@ printDoc :: !d -> String | docToDocBlock{|*|} d
*/
generic docToDocBlock d :: !Bool !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
......@@ -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,
PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc
constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc
constructorToFunctionDoc d =
......@@ -186,7 +193,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 +237,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 * "
......@@ -302,8 +309,8 @@ where
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]
......
......@@ -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
......@@ -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,16 +118,17 @@ 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
# cmnt =
{ line = ss.ln
......@@ -134,7 +138,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 +172,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
......@@ -245,7 +270,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 +278,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 +296,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 +315,22 @@ where
instance children ParsedSelector where children ps = Children (tl [ps])
instance children ParsedConstructor where children pc = Children (tl [pc])
(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos a
(canBelongTo) {line,multiline} p = pos p >>= \p -> case p of
FunPos _ ln _ -> Just (if multiline (>) (>=) ln line)
LinePos _ ln -> Just (if multiline (>) (>=) ln line)
_ -> Nothing
(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos, singleLineAbove a
(canBelongTo) {line,column,multiline} elem
| singleLineAbove elem && column > 4
= Just False
| not (singleLineAbove elem) && column < 4
= Just False
= pos elem >>= \p -> case p of
FunPos _ ln _ -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
LinePos _ ln -> Just (if multiline (>) (if (singleLineAbove elem) (>=) (<=)) ln line)
_ -> Nothing
// If true, single-line documentation should be given above the element.
class singleLineAbove a :: !a -> Bool
instance singleLineAbove ParsedDefinition where singleLineAbove _ = True
instance singleLineAbove ParsedSelector where singleLineAbove _ = False
instance singleLineAbove ParsedConstructor where singleLineAbove _ = False
class pos a :: !a -> Maybe Position
......@@ -333,6 +369,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)
......
......@@ -50,8 +50,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)
......
......@@ -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)
......
......@@ -47,7 +47,7 @@ from StdMaybe import :: Maybe
/**
* A type context.
*/
:: TypeContext :== [TypeRestriction]
:: TypeContext =: TypeContext [TypeRestriction]
/**
* A restriction on a type.
......@@ -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.
......@@ -259,7 +259,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 +283,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.
*/
......
......@@ -60,44 +60,63 @@ where
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 _)
......@@ -171,11 +190,11 @@ arity (Arrow _) = abort "what is the arity of Arrow?\n" // TODO
removeTypeContexts :: !Type -> Type
removeTypeContexts (Type s ts) = Type s $ map removeTypeContexts ts
removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) []
removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) (TypeContext [])
removeTypeContexts (Var v) = Var v
removeTypeContexts (Cons v ts) = Cons v $ map removeTypeContexts ts
removeTypeContexts (Uniq t) = Uniq $ removeTypeContexts t
removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) []
removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) (TypeContext [])
removeTypeContexts (Arrow t) = Arrow (removeTypeContexts <$> t)
removeTypeContexts (Strict t) = Strict (removeTypeContexts t)
......@@ -190,11 +209,15 @@ where
consfun c = (c.cons_name, Func c.cons_args ret c.cons_context, c.cons_priority)
where ret = if td_uniq Uniq id $ Type td_name td_args
recordsToFunctions :: !TypeDef -> [(String,Type)]
recordsToFunctions {td_name,td_uniq,td_args,td_rhs=TDRRecord _ _ fields}
= [(f.rf_name, Func [arg] f.rf_type []) \\ f <- fields]
where arg = if td_uniq Uniq id $ Type td_name td_args
recordsToFunctions _ = []
selectorsToFunctions :: !TypeDef -> [(String,Type)]
selectorsToFunctions {td_name,td_uniq,td_args,td_rhs=TDRRecord _ _ fields}
= [(f.rf_name, Func [strict arg] (unStrict f.rf_type) (TypeContext [])) \\ f <- fields]
where
arg = if td_uniq Uniq id $ Type td_name td_args
unStrict t = case t of
Strict t -> t
t -> t
selectorsToFunctions _ = []
td_name :: !TypeDef -> String
td_name {td_name} = td_name
......@@ -205,6 +228,11 @@ td_uniq {td_uniq} = td_uniq
td_rhs :: !TypeDef -> TypeDefRhs
td_rhs {td_rhs} = td_rhs
strict :: !Type -> Type
strict t = case t of
Strict _ -> t
_ -> Strict t
typedef :: !String !Bool ![Type] !TypeDefRhs -> TypeDef
typedef name uniq args rhs
= {td_name=name, td_uniq=uniq, td_args=args, td_rhs=rhs}
......@@ -222,9 +250,9 @@ removeDupTypedefs [td:tds]
= [td:removeDupTypedefs $ filter (\d -> d.td_name <> td.td_name) tds]
typeRhsRestrictions :: !TypeDefRhs -> [TypeRestriction]
typeRhsRestrictions (TDRCons _ cs) = flatten [c.cons_context \\ c <- cs]
typeRhsRestrictions (TDRNewType c) = c.cons_context
typeRhsRestrictions (TDRMoreConses cs) = flatten [c.cons_context \\ c <- cs]
typeRhsRestrictions (TDRCons _ cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRNewType {cons_context=TypeContext c}) = c
typeRhsRestrictions (TDRMoreConses cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRRecord _ _ _) = []
typeRhsRestrictions (TDRSynonym _) = []
typeRhsRestrictions (TDRAbstract _) = []
......
......@@ -20,10 +20,11 @@ import qualified syntax
instance 'Clean.Types'.toTypeContext ['syntax'.TypeContext]
where
toTypeContext context
= ['Clean.Types'.Instance gds.glob_object.ds_ident.id_name (map 'Clean.Types'.toType tc_types)
\\ {tc_class=(TCClass gds),tc_types} <- context] ++
['Clean.Types'.Derivation gtc_generic.glob_object.ds_ident.id_name ('Clean.Types'.toType t)
\\ {tc_class=(TCGeneric {gtc_generic}),tc_types=[t]} <- context]
= 'Clean.Types'.TypeContext
(['Clean.Types'.Instance gds.glob_object.ds_ident.id_name (map 'Clean.Types'.toType tc_types)
\\ {tc_class=(TCClass gds),tc_types} <- context] ++
['Clean.Types'.Derivation gtc_generic.glob_object.ds_ident.id_name ('Clean.Types'.toType t)
\\ {tc_class=(TCGeneric {gtc_generic}),tc_types=[t]} <- context])
instance 'Clean.Types'.toTypeContext 'syntax'.TypeContext where toTypeContext tc = 'Clean.Types'.toTypeContext [tc]
......@@ -49,8 +50,9 @@ where
toType (TB bt) = 'Clean.Types'.Type (toString bt) []
toType (TV tv) = 'Clean.Types'.Var tv.tv_ident.id_name
toType (GTV tv) = 'Clean.Types'.Var tv.tv_ident.id_name
toType (t1 --> t2) = 'Clean.Types'.Func ['Clean.Types'.toType t1] ('Clean.Types'.toType t2) []
toType (t1 --> t2) = 'Clean.Types'.Func ['Clean.Types'.toType t1] ('Clean.Types'.toType t2) ('Clean.Types'.TypeContext [])
toType ((CV cv) :@: ats) = 'Clean.Types'.Cons cv.tv_ident.id_name (map 'Clean.Types'.toType ats)
toType (TFA tvas t) = 'Clean.Types'.Forall (map 'Clean.Types'.toType tvas) ('Clean.Types'.toType t) ('Clean.Types'.TypeContext [])
toType (TFAC tvas t tc) = 'Clean.Types'.Forall (map 'Clean.Types'.toType tvas) ('Clean.Types'.toType t) ('Clean.Types'.toTypeContext tc)
toType TArrow = 'Clean.Types'.Arrow Nothing
toType (TArrow1 t) = 'Clean.Types'.Arrow (Just ('Clean.Types'.toType t))
......@@ -154,7 +156,7 @@ where
mapM coclType args >>= \argts ->
allowNewIdents False >>|
coclType ewl_expr >>= \rt ->
store id ('Clean.Types'.Func argts rt [])
store id ('Clean.Types'.Func argts rt ('Clean.Types'.TypeContext []))
coclType _
= fail
......
......@@ -160,20 +160,20 @@ where
uniq parser = pToken TStar >>| parser
optContext :: Parser Token TypeContext
optContext = liftM2 (++) (context <|> pure []) (uniquenessEqualities <|> pure [])
optContext = liftM2 (\(TypeContext a) (TypeContext b)->TypeContext (a ++ b)) (context <|> pure (TypeContext [])) (uniquenessEqualities <|> pure (TypeContext []))
addContextAsConstFunction :: (Parser Token Type) -> Parser Token Type
addContextAsConstFunction parser =
parser >>= \t -> pPeek >>= \tks -> case tks of
[TPipe:_] -> (pure [] <|> optContext) >>= \c -> case c of
[] -> pure t
c -> pure $ Func [] t c
[TPipe:_] -> (pure (TypeContext []) <|> optContext) >>= \c -> case c of
TypeContext [] -> pure t
c -> pure $ Func [] t c
_ -> pure t
context :: Parser Token TypeContext
context = pToken TPipe >>| flatten <$> pSepBy context` (pToken TAmpersand)
context = pToken TPipe >>| typeContext o flatten <$> pSepBy context` (pToken TAmpersand)
where
context` :: Parser Token TypeContext
context` :: Parser Token [TypeRestriction]
context` = pSepBy classOrGeneric (pToken TComma) >>= \restrictions ->
some argtype >>= \ts ->
mapM (flip ($) ts) restrictions
......@@ -201,7 +201,7 @@ where
_ -> False
uniquenessEqualities :: Parser Token TypeContext
uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> []
uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> TypeContext []
where
inequality = unqvar >>| pToken TLtEq >>| unqvar
......
......@@ -21,11 +21,11 @@ import Text.GenJSON
instance zero (TypeTree v) where zero = Node (Var "ra") [] []
instance < (TypeTree v) where < (Node a _ _) (Node b _ _) = a < b
derive gLexOrd Type, Maybe, TypeRestriction
derive gLexOrd Type, Maybe, TypeRestriction, TypeContext
instance < Type where < t u = (t =?= u) =: LT
derive JSONEncode TypeTree, Type, TypeRestriction
derive JSONDecode TypeTree, Type, TypeRestriction
derive JSONEncode TypeTree, Type, TypeRestriction, TypeContext
derive JSONDecode TypeTree, Type, TypeRestriction, TypeContext
typeTreeNodes :: !(TypeTree v) -> Int
typeTreeNodes (Node _ _ cs) = 1 + sum (map typeTreeNodes cs)
......
......@@ -20,7 +20,7 @@ import Data.List
from Data.Map import :: Map, newMap
import Data.Maybe
derive gEq Type, TypeRestriction, Kind
derive gEq Type, TypeRestriction, Kind, TypeContext
isGeneralisingUnifier :: ![TVAssignment] -> Bool
isGeneralisingUnifier tvas = all isOk $ groupVars tvas []
......@@ -74,7 +74,7 @@ where
renameAndRemoveStrictness (Var v) = Var (prep +++ v)
renameAndRemoveStrictness (Cons c ts) = Cons (prep +++ c) $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Type t ts) = Type t $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Func is r tc) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (map (inTC renameAndRemoveStrictness) tc)
renameAndRemoveStrictness (Func is r (TypeContext tc)) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (TypeContext (map (inTC renameAndRemoveStrictness) tc))
renameAndRemoveStrictness (Uniq t) = Uniq $ renameAndRemoveStrictness t
renameAndRemoveStrictness (Arrow t) = Arrow (renameAndRemoveStrictness <$> t)
renameAndRemoveStrictness (Forall vs t tc) = fromJust $
......@@ -109,7 +109,7 @@ where
:: UnificationState =
{ assignments :: ![TVAssignment]
, goals :: ![(!Type, !Type)]
, goals :: ![(Type, Type)]
, used_universal_vars :: ![TypeVar]
}
assignments s :== s.UnificationState.assignments
......
......@@ -57,8 +57,8 @@ where
instance print TypeContext
where
print _ [] = []
print _ crs = printersperse False " & "
print _ (TypeContext []) = []
print _ (TypeContext crs) = printersperse False " & "
[printersperse False ", " (map corg gr) -- " " -- printersperse False " " (types $ hd gr) \\ gr <- grps]
where
grps = groupBy (\a b -> types a == types b && length (types a) == 1) crs
......@@ -69,16 +69,16 @@ instance print Type
where
print ia (Type s vs) = typeConstructorName True ia s vs
print _ (Var v) = [v]
print ia (Func [] r []) = print ia r
print ia (Func [] r (TypeContext [])) = print ia r
print _ (Func [] r tc) = r -- " | " -- tc
print ia (Func ts r []) = parens ia (printersperse True " " ts -- " -> " -- r)
print _ (Func ts r tc) = (Func ts r []) -- " | " -- tc
print ia (Func ts r (TypeContext [])) = parens ia (printersperse True " " ts -- " -> " -- r)
print _ (Func ts r tc) = (Func ts r (TypeContext [])) -- " | " -- tc
print ia (Cons tv []) = print ia tv
print ia (Cons tv ats) = parens ia (tv -- " " -- printersperse True " " ats)
print _ (Uniq t) = case t of
Type _ _ -> "*" -- t
_ -> "*" -+ t
print _ (Forall tvs t []) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")"
print _ (Forall tvs t (TypeContext [])) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")"
print _ (Forall tvs t tc) = "(A." -- printersperse True " " tvs -- ": " -- t -- " | " -- tc -- ")"
print _ (Arrow Nothing) = ["(->)"]
print _ (Arrow (Just t)) = "((->) " -+ t +- ")"
......@@ -161,10 +161,10 @@ where
instance print Constructor
where
print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context,cons_priority}
print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context=TypeContext c,cons_priority}
= if (isEmpty evars) [] ("E." -- printersperse False " " evars -- ": ") --
name -- " " -- prio -- printersperse True " " cons_args --
if (isEmpty cons_context) [] (" & " -- cons_context)
if (isEmpty c) [] (" & " -- c)
where
(name,prio) = case cons_priority of
Nothing -> ([cons_name], [])
......@@ -264,7 +264,7 @@ assign va (Arrow Nothing) = Just $ Arrow Nothing
assign va (Strict t) = Strict <$> assign va t
reduceArities :: !Type -> Type
reduceArities (Func [] r []) = r
reduceArities (Func [] r (TypeContext [])) = r
reduceArities (Func ts r tc)
| length ts > 1 = Func [reduceArities $ hd ts] (reduceArities $ Func (tl ts) r tc) tc
| otherwise = Func (map reduceArities ts) (reduceArities r) tc
......@@ -272,7 +272,7 @@ reduceArities (Type s ts) = Type s $ map reduceArities ts
reduceArities (Cons v ts) = Cons v $ map reduceArities ts
reduceArities (Uniq t) = Uniq $ reduceArities t
reduceArities (Var v) = Var v
reduceArities (Forall [] t []) = reduceArities t
reduceArities (Forall [] t (TypeContext [])) = reduceArities t
reduceArities (Forall tvs t tc) = Forall tvs (reduceArities t) tc
reduceArities (Arrow mt) = Arrow (reduceArities <$> mt)
reduceArities (Strict t) = Strict $ reduceArities t
......@@ -293,14 +293,14 @@ where
renames = [(o, "v" +++ toString n) \\ o <- removeDup $ allVars t & n <- [1..]]
renameVars :: !Type -> Type
renameVars (Type s ts) = Type s $ map renameVars ts
renameVars (Func is r tc) = Func (map renameVars is) (renameVars r) $ map renameVarsInTC tc
renameVars (Var tv) = Var $ fromJust $ lookup tv renames
renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts
renameVars (Uniq t) = Uniq $ renameVars t
renameVars (Forall vs t tc) = Forall (map renameVars vs) (renameVars t) $ map renameVarsInTC tc
renameVars (Arrow t) = Arrow $ renameVars <$> t
renameVars (Strict t) = Strict $ renameVars t
renameVars (Type s ts) = Type s $ map renameVars ts
renameVars (Func is r (TypeContext tc)) = Func (map renameVars is) (renameVars r) $ TypeContext (map renameVarsInTC tc)
renameVars (Var tv) = Var $ fromJust $ lookup tv renames
renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts
renameVars (Uniq t) = Uniq $ renameVars t
renameVars (Forall vs t (TypeContext tc)) = Forall (map renameVars vs) (renameVars t) $ TypeContext (map renameVarsInTC tc)
renameVars (Arrow t) = Arrow $ renameVars <$> t
renameVars (Strict t) = Strict $ renameVars t
renameVarsInTC :: !TypeRestriction -> TypeRestriction
renameVarsInTC (Instance c ts) = Instance c $ map renameVars ts
......@@ -321,15 +321,15 @@ where
allVars` = concatMap allVars
optConses :: !Type -> Type
optConses (Type s ts) = Type s $ map optConses ts
optConses (Func is r tc) = Func (map optConses is) (optConses r) $ map optConsesInTR tc
optConses (Var v) = Var v
optConses (Cons c []) = Var c
optConses (Cons c ts) = Cons c $ map optConses ts
optConses (Uniq t) = Uniq $ optConses t
optConses (Forall vs t tc) = Forall (map optConses vs) (optConses t) $ map optConsesInTR tc
optConses (Arrow t) = Arrow $ optConses <$> t
optConses (Strict t) = Strict $ optConses t
optConses (Type s ts) = Type s $ map optConses ts
optConses (Func is r (TypeContext tc)) = Func (map optConses is) (optConses r) $ TypeContext (map optConsesInTR tc)
optConses (Var v) = Var v
optConses (Cons c []) = Var c
optConses (Cons c ts) = Cons c $ map optConses ts
optConses (Uniq t) = Uniq $ optConses t
optConses (Forall vs t (TypeContext tc)) = Forall (map optConses vs) (optConses t) $ TypeContext (map optConsesInTR tc)
optConses (Arrow t) = Arrow $ optConses <$> t
optConses (Strict t) = Strict $ optConses t
optConsesInTR :: !TypeRestriction -> TypeRestriction
optConsesInTR (Instance c ts) = Instance c $ map optConses ts
......
......@@ -179,6 +179,8 @@ instance ArrowApply (Kleisli m) | Monad m
:: ArrowMonad a b = ArrowMonad (a () b)
instance Functor (ArrowMonad a) | Arrow a
where
fmap :: (t -> u) !(ArrowMonad a t) -> ArrowMonad a u | Arrow a
instance pure (ArrowMonad a) | Arrow a
instance <*> (ArrowMonad a) | Arrow a
......
......@@ -105,7 +105,9 @@ instance ArrowApply (->) where
instance ArrowApply (Kleisli m) | Monad m where
app = Kleisli (\(Kleisli f, x) -> f x)
instance Functor (ArrowMonad a) | Arrow a where
instance Functor (ArrowMonad a) | Arrow a
where
fmap :: (t -> u) !(ArrowMonad a t) -> ArrowMonad a u | Arrow a
fmap f (ArrowMonad m) = ArrowMonad (m >>> arr f)
instance pure (ArrowMonad a) | Arrow a
......
......@@ -14,6 +14,8 @@ from Data.Monoid import class Monoid, class Semigroup
:: RWST r w s m a = RWST !(r s -> m (a, s, w))
instance Functor (RWST r w s m) | Monad m & Monoid w
where
fmap :: (a -> b) !(RWST r w s m a) -> RWST r w s m b | Monad m & Monoid w
instance pure (RWST r w s m) | pure m & Monoid w
instance <*> (RWST r w s m) | Monad m & Monoid w
instance Monad (RWST r w s m) | Monad m & Monoid w
......
......@@ -11,8 +11,10 @@ import Control.Monad
import Control.Monad.Trans
import Control.Applicative
instance Functor (RWST r w s m) | Monad m & Monoid w where
fmap f m = liftM f m
instance Functor (RWST r w s m) | Monad m & Monoid w
where
fmap :: (a -> b) !(RWST r w s m a) -> RWST r w s m b | Monad m & Monoid w
fmap f m = liftM f m
instance pure (RWST r w s m) | pure m & Monoid w
where
......
......@@ -23,6 +23,8 @@ local :: u:((.a -> .b) -> v:(.(ReaderT .b .c .d) -> .(ReaderT .a .c .d)))
asks :: (a -> b) -> ReaderT a c b | Monad c
instance Functor (ReaderT r m) | Monad m
where
fmap :: (a -> b) !(ReaderT r m a) -> ReaderT r m b | Monad m
instance pure (ReaderT r m) | Monad m
instance <*> (ReaderT r m) | Monad m
instance Monad (ReaderT r m) | Monad m
......
......@@ -6,8 +6,10 @@ import Control.Applicative
from StdFunc import o, const
import Control.Monad.Trans
instance Functor (ReaderT r m) | Monad m where
fmap f m = liftM f m
instance Functor (ReaderT r m) | Monad m
where
fmap :: (a -> b) !(ReaderT r m a) -> ReaderT r m b | Monad m
fmap f m = liftM f m
instance pure (ReaderT r m) | Monad m
where
......
......@@ -12,6 +12,8 @@ from Data.Functor.Identity import :: Identity
:: Writer w a :== WriterT w Identity a
instance Functor (WriterT w m) | Monad m & Monoid w
where
fmap :: (a -> b) !(WriterT w m a) -> WriterT w m b | Monad m & Monoid w
instance pure (WriterT w m) | pure m & Monoid w
instance <*> (WriterT w m) | Monad m & Monoid w
instance Monad (WriterT w m) | Monad m & Monoid w
......
......@@ -8,8 +8,10 @@ import Control.Monad.Trans
from StdFunc import o
from StdTuple import fst, snd
instance Functor (WriterT w m) | Monad m & Monoid w where
fmap f m = liftM f m
instance Functor (WriterT w m) | Monad m & Monoid w
where
fmap :: (a -> b) !(WriterT w m a) -> WriterT w m b | Monad m & Monoid w
fmap f m = liftM f m
instance pure (WriterT w m) | pure m & Monoid w
where
......
......@@ -6,9 +6,9 @@ from Data.Functor import class Functor
from Control.Applicative import class pure, class <*>, class Applicative
from Control.Monad import class Monad
mapArrSt :: !(.a -> .(*st -> *(!.a, !*st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
mapArrSt :: !(.a -> .(*st -> *(.a, *st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
foldrArr :: !(a .b -> .b) !.b !.(arr a) -> .b | Array arr a
foldrArr :: !(a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
foldrArrWithKey :: !(Int a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -18,7 +18,7 @@ foldrUArr :: !(a -> .(.b -> .(*(arr a) -> *(.b, *(arr a))))) .b !*(arr a)
foldrUArrWithKey :: !(Int a -> .(.b -> .(*(arr a) -> *(.b, *(arr a))))) .b !*(arr a)
-> *(.b, *(arr a)) | Array arr a
foldlArr :: !(.b a -> .b) !.b !.(arr a) -> .b | Array arr a
foldlArr :: !(.b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
foldlArrWithKey :: !(Int .b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -30,9 +30,11 @@ mapArr :: !(a -> a) !(arr a) -> arr a | Array arr a
appendArr :: !(arr a) !(arr a) -> arr a | Array arr a
instance +++ (arr a) | Array arr a
instance +++ {a}
instance +++ {!a}
instance Functor {}, {!}
instance Functor {} where fmap :: (a -> b) !{a} -> {b}
instance Functor {!} where fmap :: (a -> b) !{!a} -> {!b}
instance pure {}
instance pure {!} where pure :: !a -> {!a}
instance <*> {}, {!}
......
......@@ -3,12 +3,12 @@ implementation module Data.Array
import StdArray, StdInt, StdOverloaded, StdClass, StdFunctions
import Data.Functor, Control.Applicative, Control.Monad
mapArrSt :: !(.a -> .(*st -> *(!.a, !*st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
mapArrSt :: !(.a -> .(*st -> *(.a, *st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
mapArrSt f arr st
#! (sz, arr) = usize arr
= mapArrSt` sz 0 f arr st
where
mapArrSt` :: !Int !Int !(.a -> .(*st -> *(!.a, !*st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
mapArrSt` :: !Int !Int !(.a -> .(*st -> *(.a, *st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
mapArrSt` sz idx f arr st
| idx == sz = (arr, st)
| otherwise
......@@ -17,7 +17,7 @@ mapArrSt f arr st
#! arr = {arr & [idx] = e}
= mapArrSt` sz (idx + 1) f arr st
foldrArr :: !(a .b -> .b) !.b !.(arr a) -> .b | Array arr a
foldrArr :: !(a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
foldrArr f b arr = foldrArrWithKey (\_ -> f) b arr
foldrArrWithKey :: !(Int a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -49,7 +49,7 @@ foldrUArrWithKey f b arr
#! (res, arr) = foldUArr` sz (idx + 1) b arr
= f idx elem res arr
foldlArr :: !(.b a -> .b) !.b !.(arr a) -> .b | Array arr a
foldlArr :: !(.b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
foldlArr f b arr = foldlArrWithKey (\_ -> f) b arr
foldlArrWithKey :: !(Int .b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -111,11 +111,20 @@ appendArr l r
addWithOffset totalSz offset oldArr newArr
= foldrArrWithKey (\idx oldEl newArr -> {newArr & [idx + offset] = oldEl}) newArr oldArr
instance +++ (arr a) | Array arr a where
instance +++ {a} where
(+++) l r = appendArr l r
instance +++ {!a} where
(+++) l r = appendArr l r
instance Functor {}
where
fmap :: (a -> b) !{a} -> {b}
fmap f arr = {f a\\a<-:arr}
instance Functor {} where fmap f arr = {f a\\a<-:arr}
instance Functor {!} where fmap f arr = {f a\\a<-:arr}
instance Functor {!}
where
fmap :: (a -> b) !{!a} -> {!b}
fmap f arr = {f a\\a<-:arr}
instance pure {}
where
......
......@@ -50,13 +50,13 @@ instance asinh (Complex a) | Ord a & Eq a & AllGeo a & Arith a & pi a & sqrt a &
instance acosh (Complex a) | Ord a & Eq a & AllGeo a & Arith a & pi a & sqrt a & ln a
instance atanh (Complex a) | Ord a & Eq a & AllGeo a & Arith a & pi a & sqrt a & ln a
realPart :: (Complex a) -> a
imagPart :: (Complex a) -> a
realPart :: !(Complex a) -> a
imagPart :: !(Complex a) -> a
mkPolar :: a a -> Complex a | cos a & sin a & * a
cis :: a -> Complex a | cos a & sin a
polar :: (Complex a) -> (a, a) | Ord a & Eq a & atan a & sqrt a & MultDiv a & PlusMin a & pi a
magnitude :: (Complex a) -> a | sqrt a & * a & + a
phase :: (Complex a) -> a | Ord a & Eq a & atan a & MultDiv a & PlusMin a & pi a
magnitude :: !(Complex a) -> a | sqrt a & * a & + a
phase :: !(Complex a) -> a | Ord a & Eq a & atan a & MultDiv a & PlusMin a & pi a
conjugate :: (Complex a) -> Complex a | ~ a
conjugate :: !(Complex a) -> Complex a | ~ a
......@@ -129,10 +129,10 @@ instance acosh (Complex a) | Ord a & Eq a & AllGeo a & Arith a & pi a & sqrt a &
instance atanh (Complex a) | Ord a & Eq a & AllGeo a & Arith a & pi a & sqrt a & ln a where
atanh z = (one/two) * ln ((one+z) / (one-z))
realPart :: (Complex a) -> a
realPart :: !(Complex a) -> a
realPart (x :+ _) = x
imagPart :: (Complex a) -> a
imagPart :: !(Complex a) -> a
imagPart (_ :+ x) = x
mkPolar :: a a -> Complex a | cos a & sin a & * a
......@@ -144,10 +144,10 @@ cis theta = cos theta :+ sin theta
polar :: (Complex a) -> (a, a) | Ord a & Eq a & atan a & sqrt a & MultDiv a & PlusMin a & pi a
polar z = (magnitude z, phase z)
magnitude :: (Complex a) -> a | sqrt a & * a & + a
magnitude :: !(Complex a) -> a | sqrt a & * a & + a
magnitude (x :+ y) = sqrt (x*x + y*y)
phase :: (Complex a) -> a | Ord a & Eq a & atan a & MultDiv a & PlusMin a & pi a
phase :: !(Complex a) -> a | Ord a & Eq a & atan a & MultDiv a & PlusMin a & pi a
phase (x :+ y)
| x > zero = atan (y/x)
| x < zero && y >= zero = atan (y/x) + pi
......@@ -156,7 +156,7 @@ phase (x :+ y)
| x == zero && y < zero = pi / two
= undef
conjugate :: (Complex a) -> Complex a | ~ a
conjugate :: !(Complex a) -> Complex a | ~ a
conjugate (x :+ y) = x :+ (~y)
//Ugly
......
......@@ -5,4 +5,4 @@ definition module Data.Data
//
// Left True =+?= Left False == True
//
(=+?=) infix 6 :: a a -> Bool
(=+?=) infix 6 :: !a !a -> Bool
......@@ -7,6 +7,6 @@ import StdOverloaded, StdCleanTypes, StdString
//
// Left True =+?= Left False == True
//
(=+?=) infix 6 :: a a -> Bool
// TODO: this can probably be: pushD_a 0; pushD_a 1; pop_a 2; eqI
(=+?=) infix 6 :: !a !a -> Bool
(=+?=) l r = toString (CTToCons l) == toString (CTToCons r)
definition module Data.Encoding.GenBinary
/**
* This module provides a compact binary encoding for arbitrary values.
* The encoding is provided as character array.
* Choices of ADTs are represented by a single bit.
* Values of basic types (except `Bool`), arrays and lists are stored byte-aligned, which wastes only little space,
* but significantly improves encoding and decoding time.
*
* @property-bootstrap
* import StdEnv, Data.Maybe.Gast, Data.Maybe.GenPrint, Data.Maybe.GenBinary
*
* :: ADT = A String | B ADT | C ADT ADT | D ADT ADT ADT
*
* derive gEq ADT
* derive class GenBinary ADT
* derive class Gast ADT
*
* instance == ADT where
* == x y = x === y
*
* :: Record = {a :: ADT, b :: ADT , c :: ADT}
*
* derive gEq Record
* derive class GenBinary Record
* derive class Gast Record
*
* instance == Record where
* == x y = x === y
*
* @property-test-with a = Maybe Bool
* @property-test-with a = Int
* @property-test-with a = String
* @property-test-with a = Char
* @property-test-with a = Real
* @property-test-with a = (Int, Int)
* @property-test-with a = (String, String)
* @property-test-with a = (String, Int)
* @property-test-with a = (Int, String)
* @property-test-with a = [Bool]
* @property-test-with a = [Int]
* @property-test-with a = [String]
* @property-test-with a = [Char]
* @property-test-with a = [Real]
* @property-test-with a = ADT
* @property-test-with a = Record
*/
from StdGeneric import :: UNIT (..), :: PAIR (..), :: EITHER (..), :: CONS (..), :: OBJECT (..), :: RECORD (..),
:: FIELD (..),
:: GenericConsDescriptor{gcd_index,gcd_type_def},
:: GenericTypeDefDescriptor{gtd_conses,gtd_num_conses},
:: ConsPos(..), getConsPath
from StdInt import class + (+), instance + Int
from StdList import !!
from Data.Maybe import :: Maybe (..), instance Functor Maybe
from Data.Func import $
from Data.Functor import class Functor (fmap)
from Data.Tuple import appFst
/**
* Encodes a values as character array.
*
* @param The value.
* @result The encoded value.
*/
encode :: !a -> {#Char} | gBinaryEncodingSize{|*|}, gBinaryEncode{|*|} a
/**
* Decodes a value.
*
* @param The value encoded as character array.
* @result The corresponding value, if the provided array is a valid representation of a value.
*
* @property correctness: A.a :: a:
* // The `a == a` check is required as NaN Real values do not equal themselves.
* a == a ==> decode (encode a) =.= Just a
*/
decode :: !{#Char} -> Maybe a | gBinaryDecode{|*|} a
class GenBinary a | gBinaryEncode{|*|}, gBinaryEncodingSize{|*|}, gBinaryDecode{|*|} a
:: *EncodingSt = {es_pos :: !Int, es_bits :: !*{#Char}, es_cons_path :: ![ConsPos]}
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x st
gBinaryEncode{|CONS of d|} c (CONS x) st = c x $ encodeIntUsingNBits (ceil_log2 0 d.gcd_type_def.gtd_num_conses) d.gcd_index st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
derive gBinaryEncode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
// Only exported for gBinaryEncode{|CONS|}
encodeIntUsingNBits :: !Int !Int !*EncodingSt -> *EncodingSt
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x s
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x s
gBinaryEncodingSize{|CONS of d|} c (CONS x) s = c x $ ceil_log2 s d.gcd_type_def.gtd_num_conses
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
derive gBinaryEncodingSize Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
generic gBinaryDecode a :: !*EncodingSt -> (!Maybe a, !*EncodingSt)
gBinaryDecode{|UNIT|} st = (Just UNIT, st)
gBinaryDecode{|PAIR|} fx fy st
# (mbX, st) = fx st
# (mbY, st) = fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st = case st.es_cons_path of
[] = (Nothing, st)
[ConsLeft:path] = appFst (fmap LEFT) $ fl {st & es_cons_path=path}
[ConsRight:path] = appFst (fmap RIGHT) $ fr {st & es_cons_path=path}
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT of {gtd_conses,gtd_num_conses}|} f st =
case decodeIntWithNBits (ceil_log2 0 gtd_num_conses) st of
(Nothing, st) = (Nothing, st)
(Just i, st) = appFst (fmap \x -> OBJECT x) $ f {st & es_cons_path=getConsPath (gtd_conses!!i)}
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
derive gBinaryDecode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
// This is only exported because it is used in exposed generic definitions.
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
decodeIntWithNBits :: !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
ceil_log2 :: !Int !Int -> Int
implementation module Data.Encoding.GenBinary
import StdGeneric, StdEnv
import Data._Array, Data.Func, Data.Maybe, Data.Functor, Data.Tuple, Data.Array
import System._Unsafe
decode :: !{#Char} -> Maybe a | gBinaryDecode{|*|} a
decode binary = fst $ gBinaryDecode{|*|} $ mkEncodingSt {x \\ x <-: binary}
encode :: !a -> {#Char} | gBinaryEncodingSize{|*|}, gBinaryEncode{|*|} a
encode x
#! encoded_size = gBinaryEncodingSize{|*|} x 0
#! arr_size = (encoded_size+7) >> 3
#! bits = createArray arr_size '\0'
= (gBinaryEncode{|*|} x (mkEncodingSt bits)).es_bits
mkEncodingSt :: !*{#Char} -> *EncodingSt
mkEncodingSt arr = {es_pos = 0, es_bits = arr, es_cons_path=[]}
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|Int|} x st = encodeInt x st
gBinaryEncode{|Real|} x st = encodeReal x st
gBinaryEncode{|Char|} x st = encodeChar x st
gBinaryEncode{|Bool|} x st = encodeBool x st
gBinaryEncode{|String|} xs st = encodeArray encodeChar xs st
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x st
gBinaryEncode{|CONS of d|} c (CONS x) st = c x $ encodeIntUsingNBits (ceil_log2 0 d.gcd_type_def.gtd_num_conses) d.gcd_index st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
gBinaryEncode{|{}|} c xs st = encodeArray c xs st
gBinaryEncode{|{!}|} c xs st = encodeArray c xs st
gBinaryEncode{|[]|} c xs st = encodeList c xs st
encodeInt :: !Int !*EncodingSt -> *EncodingSt
encodeInt int st = encodeIntUsingNBytes (IF_INT_64_OR_32 8 4) int st
encodeChar :: !Char !*EncodingSt -> *EncodingSt
encodeChar c st = encodeIntUsingNBytes 1 (toInt c) st
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
encodeBool False st = {st & es_pos = st.es_pos + 1}
encodeBool True cs=:{es_pos = pos, es_bits = bits}
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
= {cs & es_pos = inc pos, es_bits = {bits & [byte_pos] = toChar $ int bitor bit_mask}}
encodeReal :: !Real !*EncodingSt -> *EncodingSt
encodeReal real st = IF_INT_64_OR_32
(encodeInt (unsafeCoerce real) st)
(let (i1, i2) = unsafeCoerce real in encodeInt i2 $ encodeInt i1 st)
encodeArray :: !(a *EncodingSt -> *EncodingSt) !(b a) !*EncodingSt -> *EncodingSt | Array b a
encodeArray f xs st
#! st = encodeInt (size xs) st
= foldlArr (flip f) st xs
encodeList :: !(a *EncodingSt -> *EncodingSt) ![a] !*EncodingSt -> *EncodingSt
encodeList f xs st
#! st = encodeInt (length xs) st
= foldl (flip f) st xs
encodeIntUsingNBytes :: !Int !Int !*EncodingSt -> *EncodingSt
encodeIntUsingNBytes numBytes int st = encode numBytes $ withByteAlignedPosition st
where
encode :: !Int !*EncodingSt -> *EncodingSt
encode 0 st = st
encode remainingBytes st
#! byte_pos = st.es_pos >> 3
#! st =
{ st
& es_bits = {st.es_bits & [byte_pos] = toChar $ int >> ((numBytes - remainingBytes) * 8)}
, es_pos = st.es_pos + 8
}
= encode (dec remainingBytes) st
encodeIntUsingNBits :: !Int !Int !*EncodingSt -> *EncodingSt
encodeIntUsingNBits 0 _ st = st
encodeIntUsingNBits numBits int st
# st = encodeBool (int bitand 1 == 1) st
= encodeIntUsingNBits (numBits - 1) (int >> 1) st
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|Int|} _ s = (IF_INT_64_OR_32 64 32) + byteAlignedPosition s
gBinaryEncodingSize{|Real|} _ s = 64 + byteAlignedPosition s
gBinaryEncodingSize{|Char|} _ s = 8 + byteAlignedPosition s
gBinaryEncodingSize{|Bool|} _ s = 1 + s
gBinaryEncodingSize{|String|} xs s = IF_INT_64_OR_32 64 32 + size xs * 8 + byteAlignedPosition s
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x s
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x s
gBinaryEncodingSize{|CONS of d|} c (CONS x) s = c x $ ceil_log2 s d.gcd_type_def.gtd_num_conses
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
gBinaryEncodingSize{|[]|} c xs s = foldl (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
gBinaryEncodingSize{|{}|} c xs s = foldlArr (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
gBinaryEncodingSize{|{!}|} c xs s = foldlArr (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
generic gBinaryDecode a :: !*EncodingSt -> (!Maybe a, !*EncodingSt)
gBinaryDecode{|Int|} st = decodeInt st
gBinaryDecode{|Real|} st = decodeReal st
gBinaryDecode{|Char|} st = decodeChar st
gBinaryDecode{|Bool|} st = decodeBool st
gBinaryDecode{|String|} st = decodeArray decodeChar st
gBinaryDecode{|UNIT|} st = (Just UNIT, st)
gBinaryDecode{|PAIR|} fx fy st
# (mbX, st) = fx st
# (mbY, st) = fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st = case st.es_cons_path of
[] = (Nothing, st)
[ConsLeft:path] = appFst (fmap LEFT) $ fl {st & es_cons_path=path}
[ConsRight:path] = appFst (fmap RIGHT) $ fr {st & es_cons_path=path}
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT of {gtd_conses,gtd_num_conses}|} f st =
case decodeIntWithNBits (ceil_log2 0 gtd_num_conses) st of
(Nothing, st) = (Nothing, st)
(Just i, st) = appFst (fmap \x -> OBJECT x) $ f {st & es_cons_path=getConsPath (gtd_conses!!i)}
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
gBinaryDecode{|[]|} f st = decodeList f st
gBinaryDecode{|{}|} f st = decodeArray f st
gBinaryDecode{|{!}|} f st = decodeArray f st
decodeInt :: !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decodeInt st = decodeIntWithNBytes (IF_INT_64_OR_32 8 4) st
decodeChar :: !*EncodingSt -> (!Maybe Char, !*EncodingSt)
decodeChar st
# (mbInt, st) = decodeIntWithNBytes 1 st
= (toChar <$> mbInt, st)
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
decodeBool cs=:{es_pos = pos, es_bits = bits}
#! s = size bits
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
| s == byte_pos = (Nothing, cs)
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
#! bit = (bit_mask bitand int) <> 0
= (Just bit, {cs & es_pos = inc pos})
decodeReal :: !*EncodingSt -> (!Maybe Real, !*EncodingSt)
decodeReal st = IF_INT_64_OR_32 decodeReal64 decodeReal32 $ st
where
decodeReal64 st
# (mbInt, st) = decodeInt st
= (unsafeCoerce <$> mbInt, st)
decodeReal32 st
# (mbInt1, st) = decodeInt st
# (mbInt2, st) = decodeInt st
= case (mbInt1, mbInt2) of
(Just int1, Just int2) = (Just $ unsafeCoerce (int1, int2), st)
_ = (Nothing, st)
decodeArray :: !(*EncodingSt -> (Maybe a, *EncodingSt)) !*EncodingSt -> (!Maybe (b a), !*EncodingSt) | Array b a
decodeArray f st
# (mbLength, st) = decodeInt st
= case mbLength of
<