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
Cloogle
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Cloogle
Cloogle
Commits
524e88d5
Commit
524e88d5
authored
Jan 09, 2018
by
Camil Staps
🚀
1
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Put back type search
parent
4c096b3d
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
143 additions
and
60 deletions
+143
-60
CloogleDB.dcl
CloogleDB.dcl
+6
-2
CloogleDB.icl
CloogleDB.icl
+18
-2
CloogleDBFactory.icl
CloogleDBFactory.icl
+14
-7
DB.dcl
DB.dcl
+1
-1
DB.icl
DB.icl
+10
-11
Search.icl
Search.icl
+65
-6
TypeTree.dcl
TypeTree.dcl
+8
-10
TypeTree.icl
TypeTree.icl
+21
-21
No files found.
CloogleDB.dcl
View file @
524e88d5
...
...
@@ -17,13 +17,15 @@ from Cloogle import :: FunctionKind, :: SyntaxExample, :: CleanLangReportLocatio
from
Doc
import
::
FunctionDoc
,
::
TypeDoc
,
::
ClassDoc
,
::
ModuleDoc
from
DB
import
::
DB
,
::
Entry
,
::
Index
from
NGramIndex
import
::
NGramIndex
from
TypeTree
import
::
TypeTree
/**
* A storage for function types, class definitions, type definitions, etc.
*/
::
*
CloogleDB
=
{
db
::
*
DB
CloogleEntry
AnnotationKey
Annotation
,
name_ngrams
::
NGramIndex
Index
{
db
::
!*
DB
CloogleEntry
AnnotationKey
Annotation
,
name_ngrams
::
!
NGramIndex
Index
,
types
::
!
TypeTree
Index
,
module_index
::
!
Map
Location
Index
}
...
...
@@ -206,7 +208,9 @@ getIndex :: !Index !*CloogleDB -> *(Entry CloogleEntry AnnotationKey Annotation,
filterDB
::
(
CloogleEntry
->
Bool
)
!*
CloogleDB
->
*
CloogleDB
filterLocations
::
(
Location
->
Bool
)
!*
CloogleDB
->
*
CloogleDB
filterName
::
!
String
!*
CloogleDB
->
*
CloogleDB
filterUnifying
::
!
Type
!*
CloogleDB
->
*
CloogleDB
allModules
::
!*
CloogleDB
->
*([
ModuleEntry
],
*
CloogleDB
)
allTypeDefs
::
!*
CloogleDB
->
*([
TypeDefEntry
],
*
CloogleDB
)
getEntries
::
!*
CloogleDB
->
*([(
CloogleEntry
,
Map
AnnotationKey
Annotation
)],
*
CloogleDB
)
CloogleDB.icl
View file @
524e88d5
...
...
@@ -229,10 +229,11 @@ syncDB :: !Int !*CloogleDB -> *CloogleDB
syncDB
_
db
=
db
saveDB
::
*
CloogleDB
*
File
->
*(*
CloogleDB
,
*
File
)
saveDB
wrapper
=:{
db
,
module_index
,
name_ngrams
}
f
saveDB
wrapper
=:{
db
,
module_index
,
name_ngrams
,
types
}
f
#
(
db
,
f
)
=
'
DB
'.
saveDB
db
f
#
f
=
write
module_index
f
#
f
=
write
name_ngrams
f
#
f
=
write
types
f
=
({
wrapper
&
db
=
db
},
f
)
where
write
::
a
*
File
->
*
File
|
JSONEncode
{|*|}
a
...
...
@@ -246,10 +247,13 @@ openDB f
|
not
ok
=
(
Nothing
,
f
)
#
((
ok
,
name_ngrams
),
f
)
=
appFst
isJustU
$
read
f
|
not
ok
=
(
Nothing
,
f
)
#
((
ok
,
types
),
f
)
=
appFst
isJustU
$
read
f
|
not
ok
=
(
Nothing
,
f
)
=
(
Just
{
db
=
fromJust
db
,
module_index
=
fromJust
module_index
,
name_ngrams
=
fromJust
name_ngrams
,
types
=
fromJust
types
}
,
f
)
...
...
@@ -282,13 +286,25 @@ filterName s wrap=:{db,name_ngrams}
#
db
=
'
DB
'.
searchIndices
indices
db
=
{
wrap
&
db
=
db
}
where
indices
=
[(
i
,
MatchingNGrams
,
NGrams
n
)
\\
(
i
,
n
)
<-
'
NGrams
'.
search
s
name_ngrams
]
indices
=
[(
i
,[(
MatchingNGrams
,
NGrams
n
)])
\\
(
i
,
n
)
<-
'
NGrams
'.
search
s
name_ngrams
]
filterUnifying
::
!
Type
!*
CloogleDB
->
*
CloogleDB
filterUnifying
t
wrap
=:{
db
,
types
}
#
db
=
'
DB
'.
searchIndices
idxs
db
=
{
wrap
&
db
=
db
}
where
idxs
=
[(
idx
,[])
\\
idx
<-
sort
$
findUnifying
t
types
]
allModules
::
!*
CloogleDB
->
*([
ModuleEntry
],
*
CloogleDB
)
allModules
wrap
=:{
db
,
module_index
}
#
(
mods
,
db
)
=
getIndices
(
elems
module_index
)
db
=
([
me
\\
{
value
=
ModuleEntry
me
}
<-
mods
],
{
wrap
&
db
=
db
})
allTypeDefs
::
!*
CloogleDB
->
*([
TypeDefEntry
],
*
CloogleDB
)
allTypeDefs
wrap
=:{
db
}
#
(
es
,
db
)
=
'
DB
'.
allEntries
db
=
([
tde
\\
TypeDefEntry
tde
<-
es
],
{
wrap
&
db
=
db
})
getEntries
::
!*
CloogleDB
->
*([(
CloogleEntry
,
Map
AnnotationKey
Annotation
)],
*
CloogleDB
)
getEntries
wrap
=:{
db
}
#
(
es
,
db
)
=
'
DB
'.
getEntries
db
...
...
CloogleDBFactory.icl
View file @
524e88d5
...
...
@@ -65,6 +65,7 @@ from DB import :: DB, :: Index(..), newDB, instance == Index
import
qualified
DB
import
qualified
CloogleDB
as
CDB
from
NGramIndex
import
::
NGramIndex
,
newNGramIndex
,
index
from
TypeTree
import
::
TypeTree
,
instance
zero
(
TypeTree
v
),
addType
from
CloogleDB
import
::
CloogleDB
{..},
::
Annotation
,
::
AnnotationKey
,
::
Location
(
Location
,
NoLocation
),
...
...
@@ -113,10 +114,14 @@ finaliseDb tdb
#
db
=
newDB
entries
#
(
names
,
db
)
=
collectNames
db
#
name_ngrams
=
foldr
(
uncurry
index
)
(
newNGramIndex
3
True
)
names
=
{
db
=
db
,
module_index
=
'M'
.
newMap
,
name_ngrams
=
name_ngrams
}
=
{
db
=
db
,
module_index
=
'M'
.
newMap
,
name_ngrams
=
name_ngrams
,
types
=
foldr
(
uncurry
addType
)
zero
[(
snd
$
'T'
.
prepare_unification
False
(
map
'
CDB
'.
getTypeDef
typedefs
)
$
'T'
.
removeTypeContexts
t
,
i
)
\\
(
i
,
FunctionEntry
fe
)
<-
entridxs
,
Just
t
<-
[
fe
.
fe_type
<|>
(
docType
=<<
fe
.
fe_documentation
)]]
}
where
collectNames
=
'
DB
'.
scan
(\
i
v
ivs
->
case
'
CDB
'.
getLocation
v
of
Nothing
->
ivs
...
...
@@ -124,7 +129,7 @@ where
entries
=
[
FunctionEntry
fun
\\
funs
<-
tdb
.
temp_functions
,
fun
<-
funs
]
++
[
TypeDefEntry
td
\\
tds
<-
tdb
.
temp_types
,
td
<-
tds
]
++
map
TypeDefEntry
typedefs
++
[
ModuleEntry
mod
\\
mod
<-
tdb
.
temp_modules
]
++
[
ClassEntry
cls
\\
clss
<-
tdb
.
temp_classes
,
(
cls
,
funs
)
<-
clss
]
++
[
FunctionEntry
...
...
@@ -136,8 +141,10 @@ where
_
->
False
}
\\
clss
<-
tdb
.
temp_classes
,
(
cls
,
funs
)
<-
clss
,
(
fname
,
fun
)
<-
funs
]
entridxs
=
zip2
(
indexList
entries
)
entries
idxhd
f
=
hd
[
Index
idx
\\
(
idx
,
e
)
<-
entridxs
|
f
e
]
entridxs
=
zip2
[
Index
i
\\
i
<-
[
0
..]]
entries
idxhd
f
=
hd
[
idx
\\
(
idx
,
e
)
<-
entridxs
|
f
e
]
typedefs
=
[
td
\\
tds
<-
tdb
.
temp_types
,
td
<-
tds
]
// Exclude Root Library Aux Base module
findModules
::
![
String
]
!
String
!'
CDB
'.
Library
!
a
!
String
!*
World
...
...
DB.dcl
View file @
524e88d5
...
...
@@ -42,6 +42,6 @@ getEntries :: *(DB v ak a) -> *([(v, Map ak a)], *DB v ak a)
mapInPlace
::
(
v
->
v
)
*(
DB
v
ak
a
)
->
*(
DB
v
ak
a
)
scan
::
(
Index
v
t
->
t
)
t
*(
DB
v
ak
a
)
->
*(
t
,
*(
DB
v
ak
a
))
search
::
(
v
->
(
Bool
,
[(
ak
,
a
)]))
*(
DB
v
ak
a
)
->
*
DB
v
ak
a
|
==,
<
ak
searchIndices
::
![(!
Index
,
!
ak
,
!
a
)]
!*(
DB
v
ak
a
)
->
*
DB
v
ak
a
|
==,
<
ak
searchIndices
::
![(!
Index
,
!
[(!
ak
,
!
a
)]
)]
!*(
DB
v
ak
a
)
->
*
DB
v
ak
a
|
==,
<
ak
getIndex
::
!
Index
!*(
DB
v
ak
a
)
->
*(!
Entry
v
ak
a
,
!*(
DB
v
ak
a
))
getIndices
::
![
Index
]
!*(
DB
v
ak
a
)
->
*(![
Entry
v
ak
a
],
!*(
DB
v
ak
a
))
DB.icl
View file @
524e88d5
...
...
@@ -26,16 +26,15 @@ saveDB :: *(DB v ak a) *File -> *(*DB v ak a, *File) | JSONEncode{|*|} v
saveDB
(
DB
db
)
f
#
(
s
,
db
)
=
usize
db
#
f
=
f
<<<
toString
s
<<<
"
\n
"
#
(
db
,
f
)
=
loop
0
db
f
#
(
db
,
f
)
=
loop
0
(
s
-1
)
db
f
=
(
DB
db
,
f
)
where
loop
::
!
Int
!*{!
Entry
v
ak
a
}
!*
File
->
*(*{!
Entry
v
ak
a
},
!*
File
)
|
JSONEncode
{|*|}
v
loop
i
es
f
#
(
s
,
es
)
=
usize
es
|
i
>=
s
=
(
es
,
f
)
loop
::
!
Int
!
Int
!*{!
Entry
v
ak
a
}
!*
File
->
*(*{!
Entry
v
ak
a
},
!*
File
)
|
JSONEncode
{|*|}
v
loop
i
s
es
f
|
i
>
s
=
(
es
,
f
)
#
(
e
,
es
)
=
es
![
i
]
#
f
=
f
<<<
toJSON
e
.
value
<<<
'\n'
=
loop
(
i
+1
)
es
f
=
loop
(
i
+1
)
s
es
f
openDB
::
!*
File
->
*(!
Maybe
(*
DB
v
ak
a
),
!*
File
)
|
JSONDecode
{|*|}
v
openDB
f
...
...
@@ -126,22 +125,22 @@ where
,
annotations
=
foldr
(
uncurry
put
)
e
.
annotations
annotations
}}
searchIndices
::
![(!
Index
,
!
ak
,
!
a
)]
!*(
DB
v
ak
a
)
->
*
DB
v
ak
a
|
==,
<
ak
searchIndices
::
![(!
Index
,
!
[(!
ak
,
!
a
)]
)]
!*(
DB
v
ak
a
)
->
*
DB
v
ak
a
|
==,
<
ak
searchIndices
idxs
(
DB
db
)
#
(
s
,
db
)
=
usize
db
#
db
=
upd
0
(
s
-1
)
idxs
db
=
(
DB
db
)
where
upd
::
!
Int
!
Int
![(!
Index
,
!
ak
,
!
a
)]
!*{!
Entry
v
ak
a
}
->
*{!
Entry
v
ak
a
}
|
==,
<
ak
upd
::
!
Int
!
Int
![(!
Index
,
!
[(!
ak
,
!
a
)]
)]
!*{!
Entry
v
ak
a
}
->
*{!
Entry
v
ak
a
}
|
==,
<
ak
upd
i
s
_
es
|
i
==
s
=
es
|
i
>
s
=
es
upd
i
s
[]
es
#
(
e
,
es
)
=
es
![
i
]
=
upd
(
i
+1
)
s
[]
{
es
&
[
i
]={
e
&
included
=
False
}}
upd
i
s
allidxs
=:[
match
=:(
Index
idx
,
k
,
v
):
idxs
]
es
upd
i
s
allidxs
=:[
match
=:(
Index
idx
,
annots
):
idxs
]
es
#
(
e
,
es
)
=
es
![
i
]
#
e
&
included
=
e
.
included
&&
include
#
e
&
annotations
=
if
e
.
included
(
put
k
v
e
.
annotation
s
)
e
.
annotations
#
e
&
annotations
=
if
e
.
included
(
foldr
(
uncurry
put
)
e
.
annotations
annot
s
)
e
.
annotations
=
upd
(
i
+1
)
s
(
if
include
idxs
allidxs
)
{
es
&
[
i
]=
e
}
where
include
=
i
==
idx
...
...
Search.icl
View file @
524e88d5
...
...
@@ -48,23 +48,44 @@ search {unify,name,className,typeName,modules,libraries,page,include_builtins,in
#
cdb
=
case
name
<|>
typeName
<|>
className
of
Nothing
->
cdb
Just
name
->
filterName
name
cdb
#
(
typedefs
,
cdb
)
=
appFst
(
map
getTypeDef
)
$
allTypeDefs
cdb
#
mbPreppedType
=
prepare_unification
True
typedefs
<$>
(
unify
>>=
parseType
o
fromString
)
#
usedSynonyms
=
'
Foldable
'.
concat
(
fst
<$>
mbPreppedType
)
#
mbType
=
snd
<$>
mbPreppedType
#
cdb
=
case
mbType
of
Nothing
->
cdb
Just
t
->
filterUnifying
t
cdb
#
(
es
,
cdb
)
=
getEntries
cdb
#
(
es
,
cdb
)
=
mapSt
makeResult
es
cdb
#
(
es
,
cdb
)
=
mapSt
(
makeResult
mbType
typedefs
usedSynonyms
)
es
cdb
=
(
sort
es
,
cdb
)
makeResult
::
(
CloogleEntry
,
Map
AnnotationKey
Annotation
)
*
CloogleDB
->
*(
Result
,
*
CloogleDB
)
makeResult
(
entry
,
annots
)
db
makeResult
::
(
Maybe
Type
)
[
TypeDef
]
[
TypeDef
]
(
CloogleEntry
,
Map
AnnotationKey
Annotation
)
*
CloogleDB
->
*(
Result
,
*
CloogleDB
)
makeResult
orgsearchtype
tdes
usedsyns
(
entry
,
annots
)
db
|
entry
=:
(
FunctionEntry
_)
#
(
FunctionEntry
fe
)
=
entry
// Parent class
#
(
cls
,
db
)
=
case
fe
.
fe_class
of
Nothing
->
(
Nothing
,
db
)
Just
i
->
case
getIndex
i
db
of
({
value
=
ClassEntry
ce
},
db
)
->
(
Just
{
cls_name
=
getName
ce
.
ce_loc
,
cls_vars
=
ce
.
ce_vars
},
db
)
=
(
FunctionResult
(
general
,
// Unifier
#
unif
=
prepare_unification
False
tdes
<$>
fe
.
fe_type
>>=
\(
syns
,
type
)
->
finish_unification
(
syns
++
usedsyns
)
<$>
(
orgsearchtype
>>=
unify
type
)
#
required_context
=
Nothing
// TODO
=
(
FunctionResult
(
{
general
&
distance
=
toInt
$
kindPenalty
fe
.
fe_kind
*
toReal
(
general
.
distance
+
sum
[
fromMaybe
0
$
contextPenalty
<$>
required_context
,
fromMaybe
0
$
unifierPenalty
<$>
unif
])
},
{
kind
=
fe
.
fe_kind
,
func
=
fromJust
(
fe
.
fe_representation
<|>
pure
(
concat
$
print
False
(
name
,
fe
)))
,
unifier
=
Nothing
// TODO
,
required_context
=
Nothing
// TODO
,
unifier
=
toStrUnifier
<$>
unif
,
required_context
=
required_context
,
cls
=
cls
,
constructor_of
=
Nothing
// TODO
,
recordfield_of
=
Nothing
// TODO
...
...
@@ -74,6 +95,44 @@ makeResult (entry, annots) db
,
result_doc
=
Nothing
// TODO
,
type_doc
=
Nothing
// TODO
}),
db
)
with
toStrUnifier
::
Unifier
->
StrUnifier
toStrUnifier
unif
=
{
StrUnifier
|
left_to_right
=
map
toStr
[
a
\\
LeftToRight
a
<-
unif
.
assignments
]
,
right_to_left
=
map
toStr
[
a
\\
RightToLeft
a
<-
unif
.
assignments
]
,
used_synonyms
=
[
(
concat
$
[
td
.
td_name
,
" "
:
intersperse
" "
$
print
False
td
.
td_args
]
,
concat
$
print
False
s
)
\\
td
=:{
td_rhs
=
TDRSynonym
s
}
<-
unif
.
Unifier
.
used_synonyms
]
}
where
toStr
(
var
,
type
)
=
(
var
,
concat
$
print
False
type
)
kindPenalty
::
FunctionKind
->
Real
kindPenalty
RecordField
=
1.2
kindPenalty
Constructor
=
1.1
kindPenalty
_
=
1.0
contextPenalty
::
[(
String
,
[
LocationResult
])]
->
Int
contextPenalty
required_context
=
length
[
0
\\
(_,[])
<-
required_context
]
unifierPenalty
::
Unifier
->
Int
unifierPenalty
unif
=
length
unif
.
Unifier
.
used_synonyms
+
toInt
(
sum
[
typeComplexity
t
\\
(_,
t
)
<-
allTvas
unif
|
not
(
isVar
t
)])
where
allTvas
::
Unifier
->
[
TVAssignment
]
allTvas
unif
=
map
fromUnifyingAssignment
unif
.
assignments
typeComplexity
::
Type
->
Real
typeComplexity
(
Type
_
ts
)
=
1.2
*
foldr
((+)
o
typeComplexity
)
1.0
ts
typeComplexity
(
Func
is
r
_)
=
2.0
*
foldr
((+)
o
typeComplexity
)
1.0
[
r
:
is
]
typeComplexity
(
Var
_)
=
1.0
typeComplexity
(
Cons
_
ts
)
=
1.2
*
foldr
((+)
o
typeComplexity
)
1.0
ts
typeComplexity
(
Uniq
t
)
=
3.0
+
typeComplexity
t
typeComplexity
(
Forall
_
t
_)
=
3.0
+
typeComplexity
t
typeComplexity
(
Arrow
(
Just
t
))
=
5.0
+
typeComplexity
t
typeComplexity
(
Arrow
Nothing
)
=
5.0
|
entry
=:
(
TypeDefEntry
_)
#
(
TypeDefEntry
tde
)
=
entry
=
(
TypeResult
(
general
,
...
...
TypeTree.dcl
View file @
524e88d5
...
...
@@ -8,17 +8,15 @@ from Text.JSON import generic JSONEncode, generic JSONDecode, :: JSONNode
from
TypeDef
import
::
Type
from
CloogleDB
import
::
Location
::
TypeTree
v
::
TypeTree
instance
zero
TypeTree
instance
zero
(
TypeTree
v
)
derive
JSONEncode
TypeTree
derive
JSONDecode
TypeTree
typeTreeNodes
::
TypeTree
->
Int
typeTreeSize
::
TypeTree
->
Int
typeTreeDepth
::
TypeTree
->
Int
addType
::
!
Location
!
Type
!
TypeTree
->
TypeTree
findUnifying
Locations
::
!
Type
!
TypeTree
->
[
Location
]
typeTreeToGraphviz
::
TypeTree
->
Digraph
typeTreeNodes
::
(
TypeTree
v
)
->
Int
typeTreeSize
::
(
TypeTree
v
)
->
Int
typeTreeDepth
::
(
TypeTree
v
)
->
Int
addType
::
!
Type
!
v
!(
TypeTree
v
)
->
TypeTree
v
findUnifying
::
!
Type
!(
TypeTree
v
)
->
[
v
]
typeTreeToGraphviz
::
(
TypeTree
v
)
->
Digraph
TypeTree.icl
View file @
524e88d5
...
...
@@ -21,53 +21,53 @@ import TypeUtil
import
CloogleDB
::
TypeTree
=
Node
Type
[
Location
]
[
TypeTree
]
::
TypeTree
v
=
Node
Type
[
v
]
[
TypeTree
v
]
instance
zero
TypeTree
where
zero
=
Node
(
Var
"ra"
)
[]
[]
instance
zero
(
TypeTree
v
)
where
zero
=
Node
(
Var
"ra"
)
[]
[]
instance
<
TypeTree
where
<
(
Node
a
_
_)
(
Node
b
_
_)
=
a
<
b
instance
<
(
TypeTree
v
)
where
<
(
Node
a
_
_)
(
Node
b
_
_)
=
a
<
b
derive
gLexOrd
Type
,
Maybe
,
TypeRestriction
instance
<
Type
where
<
t
u
=
(
t
=?=
u
)
=:
LT
derive
JSONEncode
TypeTree
,
Type
,
TypeRestriction
,
Location
derive
JSONDecode
TypeTree
,
Type
,
TypeRestriction
,
Location
typeTreeNodes
::
TypeTree
->
Int
typeTreeNodes
::
(
TypeTree
v
)
->
Int
typeTreeNodes
(
Node
_
_
cs
)
=
1
+
sum
(
map
typeTreeNodes
cs
)
typeTreeSize
::
TypeTree
->
Int
typeTreeSize
::
(
TypeTree
v
)
->
Int
typeTreeSize
(
Node
_
vs
cs
)
=
length
vs
+
sum
(
map
typeTreeSize
cs
)
typeTreeDepth
::
TypeTree
->
Int
typeTreeDepth
::
(
TypeTree
v
)
->
Int
typeTreeDepth
(
Node
_
_
cs
)
=
maxList
[
0
:
map
((+)
1
o
typeTreeDepth
)
cs
]
addType
::
!
Location
!
Type
!
TypeTree
->
TypeTree
addType
loc
t
tree
=:(
Node
n
loc
s
children
)
addType
::
!
Type
!
v
!(
TypeTree
v
)
->
TypeTree
v
addType
t
v
tree
=:(
Node
n
v
s
children
)
|
t
generalises
n
|
n
generalises
t
=
trace_n
(
t
<+
" equivalent to "
<+
n
)
Node
n
[
loc
:
loc
s
]
children
|
otherwise
=
trace_n
(
t
<+
" generalises "
<+
n
)
Node
t
[
loc
]
[
tree
]
|
n
generalises
t
=
trace_n
(
t
<+
" equivalent to "
<+
n
)
Node
n
[
v
:
v
s
]
children
|
otherwise
=
trace_n
(
t
<+
" generalises "
<+
n
)
Node
t
[
v
]
[
tree
]
// A type may end up in different places when there are multiple types that
// generalise it. We sort on the matching types here to avoid that as much as
// is easily possible, because we want the tree to be as small as possible.
|
otherwise
=
case
appFst
sort
$
partition
(\(
Node
t`
_
_)
->
t`
generalises
t
)
children
of
([],_)
->
trace_n
(
t
<+
" added to "
<+
n
)
Node
n
locs
[
Node
t
[
loc
]
yes
:
no
]
([],_)
->
trace_n
(
t
<+
" added to "
<+
n
)
Node
n
vs
[
Node
t
[
v
]
yes
:
no
]
with
(
yes
,
no
)
=
partition
(\(
Node
c
_
_)
->
t
generalises
c
)
children
([
g
:
gs
],
rest
)
->
Node
n
locs
([
addType
loc
t
g
:
gs
]
++
rest
)
([
g
:
gs
],
rest
)
->
Node
n
vs
([
addType
t
v
g
:
gs
]
++
rest
)
findUnifying
Locations
::
!
Type
!
TypeTree
->
[
Location
]
findUnifying
Locations
t
tree
=:(
Node
n
ls
cs
)
=
case
unify
t
n
of
Nothing
->
[]
findUnifying
::
!
Type
!(
TypeTree
v
)
->
[
v
]
findUnifying
t
tree
=:(
Node
n
ls
cs
)
=
case
unify
t
n
of
Nothing
->
trace_n
(
"NO
\t
"
+++
toString
n
)
[]
Just
tvas
->
//if (not (isEmpty cs) && isGeneralisingUnifier tvas)
//(all
Loc
s tree) // TODO this fails for A.a: a, which incorrectly generalises 'a' and returns all types
(
ls
++
concatMap
(
findUnifyingLocations
t
)
cs
)
//(all
Value
s tree) // TODO this fails for A.a: a, which incorrectly generalises 'a' and returns all types
trace_n
(
"YES
\t
"
+++
toString
n
)
(
ls
++
concatMap
(
findUnifying
t
)
cs
)
allTypes
::
TypeTree
->
[(
Type
,[
Location
],[
TypeTree
])]
allTypes
::
(
TypeTree
v
)
->
[(
Type
,[
v
],[
TypeTree
v
])]
allTypes
(
Node
t
vs
cs
)
=
[(
t
,
vs
,
cs
):
concatMap
allTypes
cs
]
all
Locs
::
TypeTree
->
[
Location
]
all
Locs
(
Node
_
ls
cs
)
=
ls
++
concatMap
allLoc
s
cs
all
Values
::
(
TypeTree
v
)
->
[
v
]
all
Values
(
Node
_
ls
cs
)
=
ls
++
concatMap
allValue
s
cs
typeTreeToGraphviz
::
TypeTree
->
Digraph
typeTreeToGraphviz
::
(
TypeTree
v
)
->
Digraph
typeTreeToGraphviz
tree
=
Digraph
"Type tree"
[
GAttRankDir
RDLR
]
...
...
Camil Staps
🚀
@cstaps
mentioned in issue
cloogle-org#235 (closed)
·
Oct 10, 2020
mentioned in issue
cloogle-org#235 (closed)
mentioned in issue cloogle-org#235
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment