Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
clean-platform
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
15
Issues
15
List
Boards
Labels
Service Desk
Milestones
Merge Requests
2
Merge Requests
2
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
clean-and-itasks
clean-platform
Commits
4b86dead
Verified
Commit
4b86dead
authored
Oct 17, 2018
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Fix "function may fail" errors
parent
702b3151
Pipeline
#15133
passed with stage
in 1 minute and 14 seconds
Changes
45
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
45 changed files
with
310 additions
and
154 deletions
+310
-154
src/libraries/OS-Independent/Clean/Doc.dcl
src/libraries/OS-Independent/Clean/Doc.dcl
+1
-1
src/libraries/OS-Independent/Clean/Doc.icl
src/libraries/OS-Independent/Clean/Doc.icl
+41
-12
src/libraries/OS-Independent/Clean/Types.icl
src/libraries/OS-Independent/Clean/Types.icl
+35
-18
src/libraries/OS-Independent/Clean/Types/Parse.icl
src/libraries/OS-Independent/Clean/Types/Parse.icl
+9
-4
src/libraries/OS-Independent/Clean/Types/Util.icl
src/libraries/OS-Independent/Clean/Types/Util.icl
+28
-20
src/libraries/OS-Independent/Codec/Archive/Tar.icl
src/libraries/OS-Independent/Codec/Archive/Tar.icl
+12
-10
src/libraries/OS-Independent/Control/GenFMap.icl
src/libraries/OS-Independent/Control/GenFMap.icl
+21
-11
src/libraries/OS-Independent/Control/GenMonad.icl
src/libraries/OS-Independent/Control/GenMonad.icl
+1
-0
src/libraries/OS-Independent/Data/Encoding/RunLength.icl
src/libraries/OS-Independent/Data/Encoding/RunLength.icl
+5
-1
src/libraries/OS-Independent/Data/GenEq.icl
src/libraries/OS-Independent/Data/GenEq.icl
+3
-2
src/libraries/OS-Independent/Data/GenLexOrd.icl
src/libraries/OS-Independent/Data/GenLexOrd.icl
+1
-1
src/libraries/OS-Independent/Data/Heap.icl
src/libraries/OS-Independent/Data/Heap.icl
+8
-2
src/libraries/OS-Independent/Data/IntMap/Strict.icl
src/libraries/OS-Independent/Data/IntMap/Strict.icl
+9
-5
src/libraries/OS-Independent/Data/Integer/Add.icl
src/libraries/OS-Independent/Data/Integer/Add.icl
+1
-0
src/libraries/OS-Independent/Data/Integer/Div.icl
src/libraries/OS-Independent/Data/Integer/Div.icl
+4
-1
src/libraries/OS-Independent/Data/Integer/Mul.icl
src/libraries/OS-Independent/Data/Integer/Mul.icl
+1
-0
src/libraries/OS-Independent/Data/Integer/ToInteger.icl
src/libraries/OS-Independent/Data/Integer/ToInteger.icl
+1
-0
src/libraries/OS-Independent/Data/List.icl
src/libraries/OS-Independent/Data/List.icl
+14
-8
src/libraries/OS-Independent/Data/Map.icl
src/libraries/OS-Independent/Data/Map.icl
+6
-0
src/libraries/OS-Independent/Data/Maybe.icl
src/libraries/OS-Independent/Data/Maybe.icl
+1
-0
src/libraries/OS-Independent/Data/OrdList.icl
src/libraries/OS-Independent/Data/OrdList.icl
+1
-1
src/libraries/OS-Independent/Data/Set.icl
src/libraries/OS-Independent/Data/Set.icl
+6
-0
src/libraries/OS-Independent/Data/Tree.icl
src/libraries/OS-Independent/Data/Tree.icl
+2
-0
src/libraries/OS-Independent/Database/SQL/MySQL.icl
src/libraries/OS-Independent/Database/SQL/MySQL.icl
+2
-1
src/libraries/OS-Independent/Database/SQL/SQLite.icl
src/libraries/OS-Independent/Database/SQL/SQLite.icl
+2
-0
src/libraries/OS-Independent/Deprecated/Generics/GenLib.dcl
src/libraries/OS-Independent/Deprecated/Generics/GenLib.dcl
+1
-1
src/libraries/OS-Independent/Graphics/Scalable/Image.icl
src/libraries/OS-Independent/Graphics/Scalable/Image.icl
+2
-0
src/libraries/OS-Independent/Graphics/Scalable/Internal/Image`.icl
...ries/OS-Independent/Graphics/Scalable/Internal/Image`.icl
+32
-18
src/libraries/OS-Independent/Internet/HTTP.icl
src/libraries/OS-Independent/Internet/HTTP.icl
+6
-8
src/libraries/OS-Independent/System/IO.icl
src/libraries/OS-Independent/System/IO.icl
+6
-2
src/libraries/OS-Independent/System/Options.icl
src/libraries/OS-Independent/System/Options.icl
+2
-0
src/libraries/OS-Independent/System/_Unsafe.icl
src/libraries/OS-Independent/System/_Unsafe.icl
+4
-0
src/libraries/OS-Independent/Text/Encodings/Base64.icl
src/libraries/OS-Independent/Text/Encodings/Base64.icl
+1
-0
src/libraries/OS-Independent/Text/GenJSON.icl
src/libraries/OS-Independent/Text/GenJSON.icl
+3
-0
src/libraries/OS-Independent/Text/GenParse.icl
src/libraries/OS-Independent/Text/GenParse.icl
+8
-2
src/libraries/OS-Independent/Text/GenPrint.icl
src/libraries/OS-Independent/Text/GenPrint.icl
+3
-2
src/libraries/OS-Independent/Text/GenXML.icl
src/libraries/OS-Independent/Text/GenXML.icl
+9
-5
src/libraries/OS-Independent/Text/HTML.icl
src/libraries/OS-Independent/Text/HTML.icl
+1
-0
src/libraries/OS-Independent/Text/PPrint.icl
src/libraries/OS-Independent/Text/PPrint.icl
+1
-7
src/libraries/OS-Independent/Text/Parsers/ZParsers/ParsersKernel.icl
...es/OS-Independent/Text/Parsers/ZParsers/ParsersKernel.icl
+2
-0
src/libraries/OS-Independent/Text/StringAppender.icl
src/libraries/OS-Independent/Text/StringAppender.icl
+2
-1
src/libraries/OS-Independent/Text/Terminal/VT100.icl
src/libraries/OS-Independent/Text/Terminal/VT100.icl
+2
-0
src/libraries/OS-Independent/Text/Unicode/Encodings/JS.icl
src/libraries/OS-Independent/Text/Unicode/Encodings/JS.icl
+7
-8
src/libraries/OS-Independent/Text/Unicode/UChar.icl
src/libraries/OS-Independent/Text/Unicode/UChar.icl
+2
-1
tests/linux64/Makefile
tests/linux64/Makefile
+1
-1
No files found.
src/libraries/OS-Independent/Clean/Doc.dcl
View file @
4b86dead
...
...
@@ -253,7 +253,7 @@ 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
d
,
RECORD
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
...
...
src/libraries/OS-Independent/Clean/Doc.icl
View file @
4b86dead
...
...
@@ -114,14 +114,18 @@ parseDoc s = docBlockToDoc{|*|} (Left [s])
generic
docBlockToDoc
d
::
!(
Either
[
String
]
DocBlock
)
->
Either
ParseError
(!
d
,
![
ParseWarning
])
docBlockToDoc
{|
String
|}
(
Left
[])
=
Left
InternalNoDataError
docBlockToDoc
{|
String
|}
(
Left
ss
)
=
Right
(
trim
$
last
ss
,
[])
docBlockToDoc
{|
String
|}
_
=
abort
"error in docBlockToDoc{|String|}
\n
"
docBlockToDoc
{|[]|}
fx
(
Left
ss
)
=
(\
vws
->
(
map
fst
vws
,
flatten
(
map
snd
vws
))
)
<$>
mapM
fx
(
map
(
Left
o
pure
)
ss
)
docBlockToDoc
{|
Maybe
|}
fx
(
Left
[])
=
Right
(
Nothing
,
[])
docBlockToDoc
{|[]|}
_
_
=
abort
"error in docBlockToDoc{|[]|}
\n
"
docBlockToDoc
{|
Maybe
|}
fx
(
Left
[])
=
Right
(
Nothing
,
[])
docBlockToDoc
{|
Maybe
|}
fx
ss
=:(
Left
_)
=
appFst
Just
<$>
fx
ss
docBlockToDoc
{|
Maybe
|}
_
_
=
abort
"error in docBlockToDoc{|Maybe|}
\n
"
docBlockToDoc
{|
UNIT
|}
_
=
Right
(
UNIT
,
[])
docBlockToDoc
{|
PAIR
|}
fx
fy
db
=:(
Right
_)
=
liftA2
(\(
x
,
ws
)
(
y
,
ws`
)
->
(
PAIR
x
y
,
ws
++
ws`
))
(
fx
db
)
(
fy
db
)
docBlockToDoc
{|
FIELD
of
d
|}
fx
(
Right
db
)
=
case
fx
(
Left
[
v
\\
(
k
,
v
)
<-
db
|
k
matches
d
.
gfd_name
])
of
docBlockToDoc
{|
PAIR
|}
_
_
_
=
abort
"error in docBlockToDoc{|PAIR|}
\n
"
docBlockToDoc
{|
FIELD
of
{
gfd_name
}|}
fx
(
Right
db
)
=
case
fx
(
Left
[
v
\\
(
k
,
v
)
<-
db
|
k
matches
gfd_name
])
of
Right
(
f
,
ws
)
->
Right
(
FIELD
f
,
ws
)
Left
InternalNoDataError
->
Left
(
MissingField
d
.
gfd_name
)
Left
InternalNoDataError
->
Left
(
MissingField
gfd_name
)
Left
e
->
Left
e
where
(
matches
)
infix
4
::
!
String
!
String
->
Bool
...
...
@@ -132,6 +136,7 @@ where
k`
==
"return"
&&
name
==
"results"
where
k`
=
{
if
(
c
==
'-'
)
'_'
c
\\
c
<-:
k
}
docBlockToDoc
{|
FIELD
of
{
gfd_name
}|}
_
_
=
abort
"error in docBlockToDoc{|FIELD|}
\n
"
docBlockToDoc
{|
RECORD
|}
fx
(
Left
[
s
])
=
case
parseDocBlock
s
of
Right
(
db
,
ws
)
->
case
fx
(
Right
db
)
of
Right
(
v
,
ws`
)
->
Right
(
RECORD
v
,
ws
++
ws`
)
...
...
@@ -147,6 +152,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
docBlockToDoc
{|
OBJECT
|}
fx
doc
=
appFst
OBJECT
<$>
fx
doc
docBlockToDoc
{|
MultiLineString
|}
(
Left
[
s
])
=
Right
(
MultiLine
$
trimMultiLine
$
split
"
\n
"
s
,
[])
docBlockToDoc
{|
MultiLineString
|}
_
=
abort
"error in docBlockToDoc{|MultiLineString|}
\n
"
docBlockToDoc
{|
ParamDoc
|}
(
Left
[
s
])
=
case
findName
(
fromString
s
)
of
Just
(
name
,
rest
)
->
Right
(
...
...
@@ -162,11 +168,13 @@ where
|
not
(
isEmpty
name
)
&&
not
(
isEmpty
cs
)
&&
hd
cs
==
':'
=
Just
(
toString
name
,
dropWhile
isSpace
(
tl
cs
))
=
Nothing
docBlockToDoc
{|
ParamDoc
|}
_
=
abort
"error in docBlockToDoc{|ParamDoc|}
\n
"
docBlockToDoc
{|
Type
|}
(
Left
[])
=
Left
InternalNoDataError
docBlockToDoc
{|
Type
|}
(
Left
ss
)
=
case
[
v
\\
Just
v
<-
map
(
'T'
.
parseType
o
fromString
)
ss
]
of
[]
->
Left
(
UnknownError
"no parsable type"
)
vs
->
Right
(
last
vs
,
[])
docBlockToDoc
{|
Type
|}
_
=
abort
"error in docBlockToDoc{|Type|}
\n
"
docBlockToDoc
{|
Property
|}
(
Left
[
s
])
=
let
[
signature
:
property
]
=
split
"
\n
"
s
in
parseSignature
signature
>>=
\(
sig
,
ws1
)
->
...
...
@@ -199,18 +207,21 @@ where
parseProperty
::
![
String
]
->
Either
ParseError
(!
String
,
![
ParseWarning
])
parseProperty
ss
=
Right
(
trimMultiLine
ss
,
[])
docBlockToDoc
{|
Property
|}
_
=
abort
"error in docBlockToDoc{|Property|}
\n
"
docBlockToDoc
{|
PropertyVarInstantiation
|}
(
Left
[
s
])
=
case
split
"="
s
of
[
var
:
type
:[]]
->
case
'T'
.
parseType
(
fromString
type
)
of
Just
t
->
Right
(
PropertyVarInstantiation
(
trim
var
,
t
),
[])
Nothing
->
Left
(
UnknownError
"type could not be parsed"
)
_
->
Left
(
UnknownError
"property var instantiation could not be parsed"
)
docBlockToDoc
{|
PropertyVarInstantiation
|}
_
=
abort
"error in docBlockToDoc{|PropertyVarInstantiation|}
\n
"
docBlockToDoc
{|
PropertyTestGenerator
|}
(
Left
[
s
])
=
case
'T'
.
parseType
(
fromString
sig
)
of
Just
t
->
Right
(
PropertyTestGenerator
t
(
trimMultiLine
imp
),
[])
Nothing
->
Left
(
UnknownError
"type could not be parsed"
)
where
[
sig
:
imp
]
=
split
"
\n
"
s
docBlockToDoc
{|
PropertyTestGenerator
|}
_
=
abort
"error in docBlockToDoc{|PropertyTestGenerator|}
\n
"
derive
docBlockToDoc
ModuleDoc
,
FunctionDoc
,
ClassMemberDoc
,
ConstructorDoc
,
ClassDoc
,
TypeDoc
...
...
@@ -225,31 +236,40 @@ printDoc d = join "\n * "
]
+++
"
\n
*/"
where
(
Right
fields`
)
=
docToDocBlock
{|*|}
False
d
fields`
=
case
docToDocBlock
{|*|}
False
d
of
Right
fs
->
fs
_
->
abort
"error in printDoc
\n
"
fields
=
filter
((<>)
"description"
o
fst
)
fields`
desc
=
lookup
"description"
fields`
generic
docToDocBlock
a
::
Bool
a
->
Either
[
String
]
DocBlock
docToDocBlock
{|
String
|}
True
s
=
Left
[
s
]
docToDocBlock
{|
String
|}
_
_
=
abort
"error in docToDocBlock{|String|}
\n
"
docToDocBlock
{|[]|}
fx
True
xs
=
Left
[
x
\\
Left
xs`
<-
map
(
fx
True
)
xs
,
x
<-
xs`
]
docToDocBlock
{|[]|}
_
_
_
=
abort
"error in docToDocBlock{|[]|}
\n
"
docToDocBlock
{|
Maybe
|}
fx
True
mb
=
case
mb
of
Nothing
->
Left
[]
Just
x
->
fx
True
x
docToDocBlock
{|
PAIR
|}
fx
fy
False
(
PAIR
x
y
)
=
Right
(
xs
++
ys
)
where
(
Right
xs
)
=
fx
False
x
(
Right
ys
)
=
fy
False
y
docToDocBlock
{|
FIELD
of
d
|}
fx
False
(
FIELD
x
)
=
Right
[(
name
,
x
)
\\
x
<-
xs
]
docToDocBlock
{|
Maybe
|}
_
_
_
=
abort
"error in docToDocBlock{|Maybe|}
\n
"
docToDocBlock
{|
PAIR
|}
fx
fy
False
(
PAIR
x
y
)
=
case
fx
False
x
of
Right
xs
->
case
fy
False
y
of
Right
ys
->
Right
(
xs
++
ys
)
_
->
abort
"error in docToDocBlock{|PAIR|}
\n
"
_
->
abort
"error in docToDocBlock{|PAIR|}
\n
"
docToDocBlock
{|
PAIR
|}
_
_
_
_
=
abort
"error in docToDocBlock{|PAIR|}
\n
"
docToDocBlock
{|
FIELD
of
d
|}
fx
False
(
FIELD
x
)
=
case
fx
True
x
of
Left
xs
->
Right
[(
name
,
x
)
\\
x
<-
xs
]
_
->
abort
"error in docToDocBlock{|FIELD|}
\n
"
where
(
Left
xs
)
=
fx
True
x
name
=
{
if
(
c
==
'_'
)
'-'
c
\\
c
<-:
name`
}
name`
|
endsWith
"ies"
d
.
gfd_name
=
d
.
gfd_name
%
(
0
,
size
d
.
gfd_name
-4
)
+++
"y"
|
endsWith
"s"
d
.
gfd_name
=
d
.
gfd_name
%
(
0
,
size
d
.
gfd_name
-2
)
|
otherwise
=
d
.
gfd_name
docToDocBlock
{|
FIELD
|}
_
_
_
=
abort
"error in docToDocBlock{|FIELD|}
\n
"
docToDocBlock
{|
RECORD
|}
fx
False
(
RECORD
x
)
=
fx
False
x
docToDocBlock
{|
RECORD
|}
_
_
_
=
abort
"error in docToDocBlock{|RECORD|}
\n
"
docToDocBlock
{|
ParamDoc
|}
True
pd
=
case
pd
.
ParamDoc
.
name
of
Nothing
->
case
pd
.
ParamDoc
.
description
of
...
...
@@ -258,12 +278,18 @@ docToDocBlock{|ParamDoc|} True pd = case pd.ParamDoc.name of
Just
n
->
case
pd
.
ParamDoc
.
description
of
Nothing
->
Left
[
n
]
Just
d
->
Left
[
n
+++
": "
+++
d
]
docToDocBlock
{|
ParamDoc
|}
_
_
=
abort
"error in docToDocBlock{|ParamDoc|}
\n
"
docToDocBlock
{|
MultiLineString
|}
True
(
MultiLine
s
)
=
Left
[
s
]
docToDocBlock
{|
MultiLineString
|}
_
_
=
abort
"error in docToDocBlock{|MultiLineString|}
\n
"
docToDocBlock
{|
Type
|}
True
t
=
Left
[
toString
t
]
docToDocBlock
{|
Type
|}
_
_
=
abort
"error in docToDocBlock{|Type|}
\n
"
docToDocBlock
{|
Property
|}
True
(
ForAll
name
args
impl
)
=
Left
[
name
+++
": A."
+++
join
"; "
[
a
+++
" :: "
<+
t
\\
(
a
,
t
)
<-
args
]
+++
":
\n
"
+++
impl
]
docToDocBlock
{|
Property
|}
_
_
=
abort
"error in docToDocBlock{|Property|}
\n
"
docToDocBlock
{|
PropertyVarInstantiation
|}
True
(
PropertyVarInstantiation
(
a
,
t
))
=
Left
[
a
+++
" = "
<+
t
]
docToDocBlock
{|
PropertyVarInstantiation
|}
_
_
=
abort
"error in docToDocBlock{|PropertyVarInstantiation|}
\n
"
docToDocBlock
{|
PropertyTestGenerator
|}
True
(
PropertyTestGenerator
t
impl
)
=
Left
[
t
<+
"
\n
"
+++
impl
]
docToDocBlock
{|
PropertyTestGenerator
|}
_
_
=
abort
"error in docToDocBlock{|PropertyTestGenerator|}
\n
"
derive
docToDocBlock
ModuleDoc
,
FunctionDoc
,
ClassMemberDoc
,
ClassDoc
,
ConstructorDoc
,
TypeDoc
...
...
@@ -302,6 +328,8 @@ where
parseFs
::
![
Char
]
![
Char
]
!
DocBlock
->
Either
ParseError
(!
DocBlock
,
![
ParseWarning
])
parseFs
field
val
d
=
Right
([(
toString
field
,
toString
(
rtrim
val
)):
d
],
[])
parseFields
_
=
abort
"error in parseDocBlock
\n
"
prepareString
::
(
String
->
Either
ParseError
[[
Char
]])
prepareString
=
checkAsterisks
o
map
trim
o
break
'\n'
o
fromString
...
...
@@ -340,6 +368,7 @@ where
toString
(
MissingAsterisk
l
)
=
"Doc error: missing leading asterisk in '"
+++
l
+++
"'"
toString
(
MissingField
f
)
=
"Doc error: required field '"
+++
f
+++
"' was missing"
toString
(
UnknownError
e
)
=
"Doc error: "
+++
e
toString
InternalNoDataError
=
"Doc error: internal parsing error"
traceParseWarnings
::
![
ParseWarning
]
!
a
->
a
traceParseWarnings
[]
x
=
x
...
...
src/libraries/OS-Independent/Clean/Types.icl
View file @
4b86dead
...
...
@@ -3,6 +3,7 @@ implementation module Clean.Types
from
StdOverloaded
import
class
==(..),
class
length
(..)
from
StdClass
import
class
Eq
import
StdList
import
StdMisc
import
StdTuple
from
StdString
import
instance
==
{#
Char
}
import
StdBool
...
...
@@ -45,6 +46,7 @@ where
name
::
!
Type
->
TypeVar
name
(
Cons
v
_)
=
v
name
(
Var
v
)
=
v
name
_
=
abort
"error in allVars
\n
"
allUniversalVars
::
!
Type
->
[
TypeVar
]
allUniversalVars
(
Forall
vs
t
tc
)
=
removeDup
(
flatten
(
map
allVars
vs
)
++
allUniversalVars
t
)
...
...
@@ -58,47 +60,60 @@ allUniversalVars (Arrow Nothing) = []
allUniversalVars
(
Strict
t
)
=
allUniversalVars
t
isVar
::
!
Type
->
Bool
isVar
(
Var
_)
=
True
;
isVar
_
=
False
isVar
t
=
t
=:(
Var
_)
fromVar
::
!
Type
->
TypeVar
fromVar
(
Var
v
)
=
v
fromVar
t
=
case
t
of
Var
v
->
v
_
->
abort
"error in fromVar
\n
"
fromVarLenient
::
!
Type
->
TypeVar
fromVarLenient
(
Var
v
)
=
v
fromVarLenient
(
Cons
v
_)
=
v
fromVarLenient
(
Uniq
t
)
=
fromVarLenient
t
fromVarLenient
t
=
case
t
of
Var
v
->
v
Cons
v
_
->
v
Uniq
t
->
fromVarLenient
t
Strict
t
->
fromVarLenient
t
_
->
abort
"missing case in fromVarLenient
\n
"
isCons
::
!
Type
->
Bool
isCons
(
Cons
_
_)
=
True
;
isCons
_
=
False
isCons
t
=
t
=:(
Cons
_
_)
isCons`
::
TypeVar
!
Type
->
Bool
isCons`
v
(
Cons
v`
_)
=
v
==
v`
;
isCons`
_
_
=
False
isCons`
v
t
=
case
t
of
Cons
v`
_
->
v
==
v`
_
->
False
isVarOrCons`
::
TypeVar
!
Type
->
Bool
isVarOrCons`
v
(
Var
v`
)
=
v
==
v`
isVarOrCons`
v
(
Cons
v`
_)
=
v
==
v`
isVarOrCons`
_
_
=
False
isVarOrCons`
v
t
=
case
t
of
Var
v`
->
v
==
v`
Cons
v`
_
->
v
==
v`
_
->
False
isType
::
!
Type
->
Bool
isType
(
Type
_
_)
=
True
;
isType
_
=
False
isType
t
=
t
=:(
Type
_
_)
isFunc
::
!
Type
->
Bool
isFunc
(
Func
_
_
_)
=
True
;
isFunc
_
=
False
isFunc
t
=
t
=:(
Func
_
_
_)
isUniq
::
!
Type
->
Bool
isUniq
(
Uniq
_)
=
True
;
isUniq
_
=
False
isUniq
t
=
t
=:(
Uniq
_)
isForall
::
!
Type
->
Bool
isForall
(
Forall
_
_
_)
=
True
;
isForall
_
=
False
isForall
t
=
t
=:(
Forall
_
_
_)
fromForall
::
!
Type
->
Type
fromForall
(
Forall
_
t
_)
=
t
fromForall
t
=
case
t
of
Forall
_
t
_
->
t
_
->
abort
"fromForall called on non-Forall
\n
"
isArrow
::
!
Type
->
Bool
isArrow
(
Arrow
_)
=
True
;
isArrow
_
=
False
isArrow
t
=
t
=:(
Arrow
_)
fromArrow
::
!
Type
->
Maybe
Type
fromArrow
(
Arrow
t
)
=
t
fromArrow
t
=
case
t
of
Arrow
t
->
t
_
->
abort
"fromArrow called on non-Arrow
\n
"
fromUnifyingAssignment
::
!
UnifyingAssignment
->
TVAssignment
fromUnifyingAssignment
(
LeftToRight
x
)
=
x
...
...
@@ -110,7 +125,9 @@ arity (Func is _ _) = length is
arity
(
Var
_)
=
0
arity
(
Cons
_
ts
)
=
length
ts
arity
(
Strict
t
)
=
arity
t
//TODO arity of Uniq / Forall / Arrow?
arity
(
Uniq
_)
=
abort
"what is the arity of Uniq?
\n
"
// TODO
arity
(
Forall
_
_
_)
=
abort
"what is the arity of Forall?
\n
"
// TODO
arity
(
Arrow
_)
=
abort
"what is the arity of Arrow?
\n
"
// TODO
removeTypeContexts
::
!
Type
->
Type
removeTypeContexts
(
Type
s
ts
)
=
Type
s
$
map
removeTypeContexts
ts
...
...
src/libraries/OS-Independent/Clean/Types/Parse.icl
View file @
4b86dead
...
...
@@ -2,6 +2,7 @@ implementation module Clean.Types.Parse
from
StdFunc
import
o
import
StdList
import
StdMisc
import
StdString
import
StdTuple
...
...
@@ -46,8 +47,12 @@ from Text.Parsers.Simple.Core import :: Parser, :: Error,
instance
==
Token
where
==
(
TIdent
a
)
(
TIdent
b
)
=
a
==
b
==
(
TVar
a
)
(
TVar
b
)
=
a
==
b
==
(
TIdent
a
)
b
=
case
b
of
TIdent
b
->
a
==
b
_
->
False
==
(
TVar
a
)
b
=
case
b
of
TVar
b
->
a
==
b
_
->
False
==
TArrow
b
=
b
=:
TArrow
==
TComma
b
=
b
=:
TComma
==
TStar
b
=
b
=:
TStar
...
...
@@ -140,10 +145,10 @@ where
<|>
liftM
Var
var
ident
::
Parser
Token
String
ident
=
(\
(
TIdent
id
)->
id
)
<$>
pSatisfy
isTIdent
ident
=
(\
tk
->
case
tk
of
TIdent
id
->
id
;
_
->
abort
"error in type parser
\n
"
)
<$>
pSatisfy
isTIdent
var
::
Parser
Token
TypeVar
var
=
(\
(
TVar
var
)->
var
)
<$>
pSatisfy
isTVar
var
=
(\
tk
->
case
tk
of
TVar
id
->
id
;
_
->
abort
"error in type parser
\n
"
)
<$>
pSatisfy
isTVar
cons
=
var
unqvar
=
var
...
...
src/libraries/OS-Independent/Clean/Types/Util.icl
View file @
4b86dead
...
...
@@ -3,6 +3,7 @@ implementation module Clean.Types.Util
import
StdArray
import
StdBool
from
StdFunc
import
flip
,
id
,
o
import
StdMisc
import
StdOrdList
import
StdString
import
StdTuple
...
...
@@ -95,15 +96,9 @@ where
instance
print
TypeDefRhs
where
print
_
(
TDRCons
ext
cs
)
=
"
\n\t
= "
--
makeADT
ext
cs
where
makeADT
::
!
Bool
![
Constructor
]
->
String
makeADT
exten
[]
=
if
exten
" .."
""
makeADT
False
[
c1
:
cs
]
=
concat
(
c1
--
"
\n
"
--
concat
[
concat
(
"
\t
| "
--
c
--
"
\n
"
)
\\
c
<-
cs
])
makeADT
True
cs
=
concat
(
makeADT
False
cs
--
"
\t
| .."
)
print
_
(
TDRNewType
c
)
=
" =: "
--
c
print
_
(
TDRCons
ext
cs
)
=
"
\n\t
= "
--
printADT
ext
cs
print
_
(
TDRMoreConses
cs
)
=
"
\n\t
| "
--
printADT
False
cs
print
_
(
TDRNewType
c
)
=
" =: "
--
c
print
_
(
TDRRecord
_
exi
fields
)
=
" ="
--
if
(
isEmpty
exi
)
[]
(
" E."
--
printersperse
False
" "
exi
--
":"
)
--
"
\n\t
"
--
makeRecord
exi
fields
...
...
@@ -124,6 +119,15 @@ where
print
_
(
TDRAbstract
(
Just
rhs
))
=
" /*"
--
rhs
--
" */"
print
_
(
TDRAbstractSynonym
t
)
=
" (:== "
--
t
--
")"
printADT
::
!
Bool
![
Constructor
]
->
String
printADT
True
cs
=
case
cs
of
[]
->
".."
cs
->
concat
(
printADT
False
cs
--
"
\t
| .."
)
printADT
False
cs
=
case
cs
of
[]
->
""
[
c1
:
cs
]
->
concat
(
c1
--
"
\n
"
--
concat
[
concat
(
"
\t
| "
--
c
--
"
\n
"
)
\\
c
<-
cs
])
typeConstructorName
::
!
Bool
!
Bool
!
String
![
Type
]
->
[
String
]
typeConstructorName
isInfix
isArg
t
as
#
isInfix
=
isInfix
&&
not
(
isEmpty
as
)
...
...
@@ -191,24 +195,28 @@ resolve_synonyms :: ('M'.Map String [TypeDef]) !Type -> ([TypeDef], Type)
resolve_synonyms
tds
(
Type
t
ts
)
#
(
syns
,
ts
)
=
appFst
(
removeDupTypedefs
o
flatten
)
$
unzip
$
map
(
resolve_synonyms
tds
)
ts
=
case
candidates
of
[]
=
(
syns
,
Type
t
ts
)
[]
->
(
syns
,
Type
t
ts
)
[
syn
=:{
td_args
,
td_rhs
=
TDRSynonym
synt
}:_]
#
newargs
=
map
((+++)
"__"
o
fromVar
)
td_args
#
(
Just
t
)
=
assignAll
[(
fromVar
a
,
Var
n
)
\\
a
<-
td_args
&
n
<-
newargs
]
synt
>>=
assignAll
[(
a
,
r
)
\\
a
<-
newargs
&
r
<-
ts
]
|
length
td_args
<>
length
ts
#
(
Type
r
rs
)
=
t
#
t
=
Type
r
$
rs
++
drop
(
length
td_args
)
ts
=
appFst
((++)
[
syn
:
syns
])
$
resolve_synonyms
tds
t
=
appFst
((++)
[
syn
:
syns
])
$
resolve_synonyms
tds
t
#
t
=
case
assignAll
[(
fromVar
a
,
Var
n
)
\\
a
<-
td_args
&
n
<-
newargs
]
synt
>>=
assignAll
[(
a
,
r
)
\\
a
<-
newargs
&
r
<-
ts
]
of
Just
t
->
t
_
->
abort
"error in resolve_synonyms_Type
\n
"
|
length
td_args
<>
length
ts
->
case
t
of
Type
r
rs
#
t
=
Type
r
$
rs
++
drop
(
length
td_args
)
ts
->
appFst
((++)
[
syn
:
syns
])
$
resolve_synonyms
tds
t
_
->
abort
"error in resolve_synonyms_Type
\n
"
->
appFst
((++)
[
syn
:
syns
])
$
resolve_synonyms
tds
t
_
->
abort
"error in resolve_synonyms_Type
\n
"
where
candidates
=
[
td
\\
td
=:{
td_rhs
=
TDRSynonym
syn
}
<-
fromMaybe
[]
$
'M'
.
get
t
tds
|
length
td
.
td_args
<=
tslen
&&
(
isType
syn
||
length
td
.
td_args
==
tslen
)]
where
tslen
=
length
ts
resolve_synonyms
tds
(
Func
is
r
tc
)
#
(
syns
,
[
r
:
is
])
=
appFst
(
removeDupTypedefs
o
flatten
)
$
unzip
$
map
(
resolve_synonyms
tds
)
[
r
:
is
]
=
(
syns
,
Func
is
r
tc
)
=
case
appFst
(
removeDupTypedefs
o
flatten
)
$
unzip
$
map
(
resolve_synonyms
tds
)
[
r
:
is
]
of
(
syns
,
[
r
:
is
])
->
(
syns
,
Func
is
r
tc
)
_
->
abort
"error in resolve_synonyms_Func
\n
"
resolve_synonyms
_
(
Var
v
)
=
([],
Var
v
)
resolve_synonyms
tds
(
Cons
v
ts
)
...
...
src/libraries/OS-Independent/Codec/Archive/Tar.icl
View file @
4b86dead
...
...
@@ -103,16 +103,18 @@ where
isOctDigit
c
=
'0'
<=
c
&&
c
<=
'7'
parseType
::
TarParser
TarFileType
parseType
=
StateT
$
\[
c
:
cs
]
->
case
c
of
'0'
=
Ok
(
NormalFile
,
cs
)
'1'
=
Ok
(
HardLink
,
cs
)
'2'
=
Ok
(
SymLink
,
cs
)
'3'
=
Ok
(
CharSpecial
,
cs
)
'4'
=
Ok
(
BlockSpecial
,
cs
)
'5'
=
Ok
(
Directory
,
cs
)
'6'
=
Ok
(
FIFO
,
cs
)
'7'
=
Ok
(
Contiguous
,
cs
)
c
=
Error
$
UnsupportedFileTypeId
c
parseType
=
StateT
$
\
cs
->
case
cs
of
[]
->
Error
UnexpectedEOS
[
c
:
cs
]
->
case
c
of
'0'
=
Ok
(
NormalFile
,
cs
)
'1'
=
Ok
(
HardLink
,
cs
)
'2'
=
Ok
(
SymLink
,
cs
)
'3'
=
Ok
(
CharSpecial
,
cs
)
'4'
=
Ok
(
BlockSpecial
,
cs
)
'5'
=
Ok
(
Directory
,
cs
)
'6'
=
Ok
(
FIFO
,
cs
)
'7'
=
Ok
(
Contiguous
,
cs
)
c
=
Error
$
UnsupportedFileTypeId
c
skip
::
Int
->
TarParser
()
skip
i
=
StateT
$
\
cs
->
Ok
((),
drop
i
cs
)
...
...
src/libraries/OS-Independent/Control/GenFMap.icl
View file @
4b86dead
...
...
@@ -37,16 +37,20 @@ bimap{|{}|} bma = {map_to = mapArray bma.map_to, map_from = mapArray bma.map_fro
generic
gLookupFMap
key
::
key
(
FMap
value
)
->
FMap
value
gLookupFMap
{|
Char
|}
key
(
FMChar
xs
)
=
lookupAssocList
key
FMEmpty
xs
gLookupFMap
{|
Char
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Char
|}
_
_
=
abort
"error in gLookupFMap{|Char|}
\n
"
gLookupFMap
{|
Int
|}
key
(
FMInt
xs
)
=
lookupAssocList
key
FMEmpty
xs
gLookupFMap
{|
Int
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Int
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Int
|}
_
_
=
abort
"error in gLookupFMap{|Int|}
\n
"
gLookupFMap
{|
Real
|}
key
(
FMReal
xs
)
=
lookupAssocList
key
FMEmpty
xs
gLookupFMap
{|
Real
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Real
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Real
|}
_
_
=
abort
"error in gLookupFMap{|Real|}
\n
"
gLookupFMap
{|
Bool
|}
False
(
FMEither
ls
rs
)
=
ls
gLookupFMap
{|
Bool
|}
True
(
FMEither
ls
rs
)
=
rs
gLookupFMap
{|
Bool
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Bool
|}
False
(
FMEither
ls
rs
)
=
ls
gLookupFMap
{|
Bool
|}
True
(
FMEither
ls
rs
)
=
rs
gLookupFMap
{|
Bool
|}
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
Bool
|}
_
_
=
abort
"error in gLookupFMap{|Bool|}
\n
"
//gLookupFMap{|UNIT|} key (FMValue v) = (FMValue v)
//gLookupFMap{|UNIT|} key FMEmpty = FMEmpty
...
...
@@ -54,9 +58,10 @@ gLookupFMap{|UNIT|} key fm = fm
gLookupFMap
{|
PAIR
|}
fx
fy
(
PAIR
kx
ky
)
fm
=
fy
ky
(
fx
kx
fm
)
gLookupFMap
{|
EITHER
|}
fl
fr
(
LEFT
key
)
(
FMEither
ls
rs
)
=
fl
key
ls
gLookupFMap
{|
EITHER
|}
fl
fr
(
LEFT
key
)
(
FMEither
ls
rs
)
=
fl
key
ls
gLookupFMap
{|
EITHER
|}
fl
fr
(
RIGHT
key
)
(
FMEither
ls
rs
)
=
fr
key
rs
gLookupFMap
{|
EITHER
|}
fl
fr
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
EITHER
|}
fl
fr
key
FMEmpty
=
FMEmpty
gLookupFMap
{|
EITHER
|}
_
_
_
_
=
abort
"error in gLookupFMap{|EITHER|}
\n
"
gLookupFMap
{|
CONS
|}
f
(
CONS
key
)
fm
=
f
key
fm
gLookupFMap
{|
FIELD
|}
f
(
FIELD
key
)
fm
=
f
key
fm
...
...
@@ -86,23 +91,27 @@ gInsertFMap{|Char|} key (new_val, FMChar xs)
=
(
old_val
,
FMChar
xs
)
gInsertFMap
{|
Char
|}
key
(
new_val
,
FMEmpty
)
=
(
FMEmpty
,
FMChar
[(
key
,
new_val
)])
gInsertFMap
{|
Char
|}
_
_
=
abort
"error in gInsertFMap{|Char|}
\n
"
gInsertFMap
{|
Int
|}
key
(
new_val
,
FMInt
xs
)
#
(
old_val
,
xs
)
=
updateAssocList
key
new_val
FMEmpty
xs
=
(
old_val
,
FMInt
xs
)
gInsertFMap
{|
Int
|}
key
(
new_val
,
FMEmpty
)
=
(
FMEmpty
,
FMInt
[(
key
,
new_val
)])
gInsertFMap
{|
Int
|}
_
_
=
abort
"error in gInsertFMap{|Int|}
\n
"
gInsertFMap
{|
Real
|}
key
(
new_val
,
FMReal
xs
)
#
(
old_val
,
xs
)
=
updateAssocList
key
new_val
FMEmpty
xs
=
(
old_val
,
FMReal
xs
)
gInsertFMap
{|
Real
|}
key
(
new_val
,
FMEmpty
)
=
(
FMEmpty
,
FMReal
[(
key
,
new_val
)])
gInsertFMap
{|
Real
|}
_
_
=
abort
"error in gInsertFMap{|Real|}
\n
"
gInsertFMap
{|
Bool
|}
False
(
v
,
FMEither
ls
rs
)
=
(
ls
,
FMEither
v
rs
)
gInsertFMap
{|
Bool
|}
False
(
v
,
FMEmpty
)
=
(
FMEmpty
,
FMEither
v
FMEmpty
)
gInsertFMap
{|
Bool
|}
True
(
v
,
FMEither
ls
rs
)
=
(
rs
,
FMEither
ls
v
)
gInsertFMap
{|
Bool
|}
True
(
v
,
FMEmpty
)
=
(
FMEmpty
,
FMEither
FMEmpty
v
)
gInsertFMap
{|
Bool
|}
False
(
v
,
FMEither
ls
rs
)
=
(
ls
,
FMEither
v
rs
)
gInsertFMap
{|
Bool
|}
False
(
v
,
FMEmpty
)
=
(
FMEmpty
,
FMEither
v
FMEmpty
)
gInsertFMap
{|
Bool
|}
True
(
v
,
FMEither
ls
rs
)
=
(
rs
,
FMEither
ls
v
)
gInsertFMap
{|
Bool
|}
True
(
v
,
FMEmpty
)
=
(
FMEmpty
,
FMEither
FMEmpty
v
)
gInsertFMap
{|
Bool
|}
_
_
=
abort
"error in gInsertFMap{|Bool|}
\n
"
gInsertFMap
{|
UNIT
|}
key
(
x
,
y
)
=
(
y
,
x
)
...
...
@@ -124,6 +133,7 @@ gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEither ls rs)
gInsertFMap
{|
EITHER
|}
fl
fr
(
RIGHT
key
)
(
v
,
FMEmpty
)
#
(
old_val
,
new_rs
)
=
fr
key
(
v
,
FMEmpty
)
=
(
FMEmpty
,
FMEither
FMEmpty
new_rs
)
gInsertFMap
{|
EITHER
|}
_
_
_
_
=
abort
"error in gInsertFMap{|EITHER|}
\n
"
gInsertFMap
{|
CONS
|}
f
(
CONS
key
)
x
=
f
key
x
gInsertFMap
{|
FIELD
|}
f
(
FIELD
key
)
x
=
f
key
x
...
...
src/libraries/OS-Independent/Control/GenMonad.icl
View file @
4b86dead
...
...
@@ -37,6 +37,7 @@ instance Monad [] where
ret
x
=
[
x
]
//(>>=) xs f = flatten (map f xs) // uniqueness typing makes it a problem because f is shared
(>>=)
[
x
:
xs
]
f
=
f
x
(>>=)
[]
_
=
[]
//-----------------------
// state monad
...
...
src/libraries/OS-Independent/Data/Encoding/RunLength.icl
View file @
4b86dead
implementation
module
Data
.
Encoding
.
RunLength
import
StdOverloaded
,
StdList
import
StdList
import
StdMisc
import
StdOverloaded
encodeInt
::
![
Int
]
->
[
Int
]
encodeInt
xs
=
reverse
(
rleInt`
xs
[])
...
...
@@ -11,6 +13,7 @@ encodeInt xs = reverse (rleInt` xs [])
rleInt`
[
x
:
xs
]
[
y
:
n
:
ys
]
|
x
==
y
=
rleInt`
xs
[
y
:
n
+
1
:
ys
]
|
otherwise
=
rleInt`
xs
[
x
:
1
:
y
:
n
:
ys
]
rleInt`
_
_
=
abort
"error in encodeInt
\n
"
decodeInt
::
![
Int
]
->
[
Int
]
decodeInt
xs
=
reverse
(
rldInt`
xs
[])
...
...
@@ -19,6 +22,7 @@ decodeInt xs = reverse (rldInt` xs [])
rldInt`
[]
acc
=
acc
rldInt`
[
0
:
x
:
xs
]
acc
=
rldInt`
xs
acc
rldInt`
[
n
:
x
:
xs
]
acc
=
rldInt`
[
n
-
1
:
x
:
xs
]
[
x
:
acc
]
rldInt`
_
_
=
abort
"error in encodeInt
\n
"
encode
::
![
a
]
->
[(
Int
,
a
)]
|
==
a
encode
xs
=
reverse
(
rle`
xs
[])
...
...
src/libraries/OS-Independent/Data/GenEq.icl
View file @
4b86dead
...
...
@@ -26,5 +26,6 @@ derive gEq [], (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
eqArray
f
xs
ys
=
size
xs
==
size
ys
&&
eq
0
(
size
xs
)
xs
ys
where