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.org
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
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Cloogle
cloogle.org
Commits
4cf0b6c4
Verified
Commit
4cf0b6c4
authored
Aug 20, 2016
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Combine all FunctionLocation, ClassLocation etc. into one Location
parent
43a0e806
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
182 additions
and
216 deletions
+182
-216
backend/CloogleServer.icl
backend/CloogleServer.icl
+37
-45
backend/TypeDB.dcl
backend/TypeDB.dcl
+44
-50
backend/TypeDB.icl
backend/TypeDB.icl
+57
-77
backend/builddb.icl
backend/builddb.icl
+44
-44
No files found.
backend/CloogleServer.icl
View file @
4cf0b6c4
...
...
@@ -70,14 +70,14 @@ import Levenshtein
}
::
ClassResult
:==
(
BasicResult
,
ClassResultExtras
)
::
ClassResultExtras
=
{
class_name
::
String
,
class_heading
::
String
,
class_funs
::
[
String
]
::
ClassResultExtras
=
{
class_name
::
String
,
class_heading
::
String
,
class_funs
::
[
String
]
,
class_instances
::
[
String
]
}
::
MacroResult
:==
(
BasicResult
,
MacroResultExtras
)
::
MacroResultExtras
=
{
macro_name
::
String
::
MacroResultExtras
=
{
macro_name
::
String
,
macro_representation
::
String
}
...
...
@@ -114,9 +114,9 @@ where
where
basic
::
Result
->
BasicResult
basic
(
FunctionResult
(
br
,_))
=
br
basic
(
TypeResult
(
br
,_))
=
br
basic
(
ClassResult
(
br
,_))
=
br
basic
(
MacroResult
(
br
,_))
=
br
basic
(
TypeResult
(
br
,_))
=
br
basic
(
ClassResult
(
br
,_))
=
br
basic
(
MacroResult
(
br
,_))
=
br
err
::
Int
String
->
Response
err
c
m
=
{
return
=
c
...
...
@@ -126,12 +126,12 @@ err c m = { return = c
,
suggestions
=
Nothing
}
E_NORESULTS
:==
127
E_NORESULTS
:==
127
E_INVALIDINPUT
:==
128
E_INVALIDNAME
:==
129
E_INVALIDTYPE
:==
130
E_INVALIDNAME
:==
129
E_INVALIDTYPE
:==
130
MAX_RESULTS
:==
15
MAX_RESULTS
:==
15
Start
w
#
(
io
,
w
)
=
stdio
w
...
...
@@ -203,45 +203,42 @@ where
// Search normal functions
#
filts
=
catMaybes
[
(\
t
_
->
isUnifiable
t
)
<$>
mbType
,
(\
n
loc
_
->
isNameMatch
(
size
n
-2
)
n
loc
)
<$>
name
,
isModMatchF
<$>
modules
,
(\
mods
loc
_
->
isModMatch
mods
loc
)
<$>
modules
]
#
funs
=
map
(\
f
->
makeFunctionResult
name
mbType
Nothing
f
db
)
$
findFunction``
filts
db
// Search macros
#
macros
=
case
name
of
Nothing
=
[]
(
Just
n
)
=
findMacro`
(\
(
ML
lib
mod
m
_)
_
->
isNameMatch
(
size
n
-2
)
n
(
FL
lib
mod
m
Nothing
)
)
db
(
Just
n
)
=
findMacro`
(\
loc
_
->
isNameMatch
(
size
n
-2
)
n
loc
)
db
#
macros
=
map
(\(
lhs
,
rhs
)
->
makeMacroResult
name
lhs
rhs
)
macros
// Search class members
#
filts
=
catMaybes
[
(\
t
_
_
_
_->
isUnifiable
t
)
<$>
mbType
,
(\
n
(
CL
lib
mod
_
_)
_
_
f
_
->
isNameMatch
(
size
n
-2
)
n
(
FL
lib
mod
f
Nothing
))
<$>
name
,
isModMatchC
<$>
modules
,
(\
n
(
Location
lib
mod
_
_)
_
_
f
_
->
isNameMatch
(
size
n
-2
)
n
(
Location
lib
mod
Nothing
f
))
<$>
name
,
(\
mods
loc
_
_
_
_
->
isModMatch
mods
loc
)
<$>
modules
]
#
members
=
findClassMembers``
filts
db
#
members
=
map
(\(
CL
lib
mod
cls
line
,
vs
,_,
f
,
et
)
->
makeFunctionResult
name
mbType
(
Just
{
cls_name
=
cls
,
cls_vars
=
vs
})
(
FL
lib
mod
f
line
,
et
)
db
)
members
#
members
=
map
(\(
Location
lib
mod
line
cls
,
vs
,_,
f
,
et
)
->
makeFunctionResult
name
mbType
(
Just
{
cls_name
=
cls
,
cls_vars
=
vs
})
(
Location
lib
mod
line
f
,
et
)
db
)
members
// Search types
#
lc
Type
Name
=
if
(
isJust
mbType
&&
isType
(
fromJust
mbType
))
#
lcName
=
if
(
isJust
mbType
&&
isType
(
fromJust
mbType
))
(
let
(
Type
name
_)
=
fromJust
mbType
in
Just
$
toLowerCase
name
)
(
toLowerCase
<$>
name
)
#
types
=
case
lc
Type
Name
of
#
types
=
case
lcName
of
(
Just
n
)
=
findType`
(\
tl
_
->
toLowerCase
(
getName
tl
)
==
n
)
db
Nothing
=
[]
#
types
=
map
(\(
tl
,
td
)
->
makeTypeResult
name
tl
td
)
types
// Search classes
#
classes
=
case
(
isNothing
mbType
,
toLowerCase
<$>
name
)
of
(
True
,
Just
c
)
=
map
(
flip
makeClassResult
db
)
$
findClass`
(\(
CL
_
_
c`
_
)
_
_
_
->
toLowerCase
c`
==
c
)
db
findClass`
(\(
Location
_
_
_
c`
)
_
_
_
->
toLowerCase
c`
==
c
)
db
_
=
[]
// Merge results
=
sort
$
funs
++
members
++
types
++
classes
++
macros
where
getName
(
TL
_
_
t
_)
=
t
getName
(
TL_Builtin
t
)
=
t
makeClassResult
::
(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
Function
Name
,
ExtendedType
)])
makeClassResult
::
(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])
TypeDB
->
Result
makeClassResult
(
CL
lib
mod
cls
line
,
vars
,
cc
,
funs
)
db
makeClassResult
(
Location
lib
mod
line
cls
,
vars
,
cc
,
funs
)
db
=
ClassResult
(
{
library
=
lib
,
filename
=
modToFilename
mod
...
...
@@ -259,8 +256,8 @@ where
}
)
makeTypeResult
::
(
Maybe
String
)
Type
Location
TypeDef
->
Result
makeTypeResult
mbName
(
TL
lib
mod
t
line
)
td
makeTypeResult
::
(
Maybe
String
)
Location
TypeDef
->
Result
makeTypeResult
mbName
(
Location
lib
mod
line
t
)
td
=
TypeResult
(
{
library
=
lib
,
filename
=
modToFilename
mod
...
...
@@ -272,7 +269,7 @@ where
}
,
{
type
=
concat
$
print
False
td
}
)
makeTypeResult
mbName
(
TL_
Builtin
t
)
td
makeTypeResult
mbName
(
Builtin
t
)
td
=
TypeResult
(
{
library
=
""
,
filename
=
""
...
...
@@ -285,8 +282,8 @@ where
,
{
type
=
concat
$
print
False
td
}
)
makeMacroResult
::
(
Maybe
String
)
Macro
Location
Macro
->
Result
makeMacroResult
mbName
(
ML
lib
mod
m
line
)
mac
makeMacroResult
::
(
Maybe
String
)
Location
Macro
->
Result
makeMacroResult
mbName
(
Location
lib
mod
line
m
)
mac
=
MacroResult
(
{
library
=
lib
,
filename
=
modToFilename
mod
...
...
@@ -302,7 +299,7 @@ where
)
makeFunctionResult
::
(
Maybe
String
)
(
Maybe
Type
)
(
Maybe
ShortClassResult
)
(
Function
Location
,
ExtendedType
)
TypeDB
->
Result
(
Location
,
ExtendedType
)
TypeDB
->
Result
makeFunctionResult
orgsearch
orgsearchtype
mbCls
(
fl
,
et
=:(
ET
type
tes
))
db
=
FunctionResult
...
...
@@ -331,8 +328,8 @@ where
)
where
(
lib
,
mod
,
fname
,
line
,
builtin
)
=
case
fl
of
(
FL
l
m
f
ln
)
=
(
l
,
m
,
f
,
ln
,
Nothing
)
(
FL_Builtin
f
)
=
(
""
,
""
,
f
,
Nothing
,
Just
True
)
(
Location
l
m
ln
f
)
=
(
l
,
m
,
f
,
ln
,
Nothing
)
(
Builtin
f
)
=
(
""
,
""
,
f
,
Nothing
,
Just
True
)
toStrUnifier
::
Unifier
->
StrUnifier
toStrUnifier
(
tvas1
,
tvas2
)
=
(
map
toStr
tvas1
,
map
toStr
tvas2
)
...
...
@@ -368,21 +365,16 @@ where
isUnifiable
::
Type
ExtendedType
->
Bool
isUnifiable
t1
(
ET
t2
_)
=
isJust
(
unify
[]
t1
(
prepare_unification
False
t2
))
isNameMatch
::
!
Int
!
String
Function
Location
->
Bool
isNameMatch
maxdist
n1
fl
#
(
n1
,
n2
)
=
({
toLower
c
\\
c
<-:
n1
},
{
toLower
c
\\
c
<-:
getName
fl
})
isNameMatch
::
!
Int
!
String
Location
->
Bool
isNameMatch
maxdist
n1
loc
#
(
n1
,
n2
)
=
({
toLower
c
\\
c
<-:
n1
},
{
toLower
c
\\
c
<-:
getName
loc
})
=
n1
==
""
||
indexOf
n1
n2
<>
-1
||
levenshtein
n1
n2
<=
maxdist
where
getName
(
FL
_
_
n
_)
=
n
;
getName
(
FL_Builtin
n
)
=
n
isModMatchF
::
![
String
]
FunctionLocation
ExtendedType
->
Bool
isModMatchF
mods
(
FL
_
mod
_
_)
_
=
isMember
mod
mods
isModMatch
C
::
![
String
]
ClassLocation
[
TypeVar
]
ClassContext
FunctionName
ExtendedType
->
Bool
isModMatch
C
mods
(
CL
_
mod
_
_)
_
_
_
_
=
isMember
mod
mods
isModMatch
::
![
String
]
Location
->
Bool
isModMatch
mods
(
Location
_
mod
_
_)
=
isMember
mod
mods
log
::
(
LogMessage
(
Maybe
Request
)
Response
)
IPAddress
*
World
->
*(
IPAddress
,
*
World
)
->
*(
IPAddress
,
*
World
)
log
msg
s
w
|
not
needslog
=
(
newS
msg
s
,
w
)
#
(
tm
,
w
)
=
localTime
w
...
...
backend/TypeDB.dcl
View file @
4cf0b6c4
...
...
@@ -29,20 +29,13 @@ from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..),
,
macro_extras
::
TypeExtras
}
::
FunctionLocation
=
FL
Library
Module
FunctionName
LineNr
|
FL_Builtin
FunctionName
::
MacroLocation
=
ML
Library
Module
MacroName
LineNr
::
ClassLocation
=
CL
Library
Module
Class
LineNr
::
TypeLocation
=
TL
Library
Module
TypeName
LineNr
|
TL_Builtin
TypeName
::
Location
=
Location
Library
Module
LineNr
Name
|
Builtin
Name
::
Name
:==
String
::
Library
:==
String
::
Module
:==
String
::
FunctionName
:==
String
::
MacroName
:==
String
::
Class
:==
String
::
GenericName
:==
String
::
TypeName
:==
String
::
LineNr
:==
Maybe
Int
derive
gEq
TypeDB
...
...
@@ -51,52 +44,53 @@ instance zero TypeDB
instance
zero
TypeExtras
instance
print
TE_Priority
instance
print
(
FunctionName
,
ExtendedType
)
getFunction
::
FunctionLocation
TypeDB
->
Maybe
ExtendedType
putFunction
::
FunctionLocation
ExtendedType
TypeDB
->
TypeDB
putFunctions
::
[(
FunctionLocation
,
ExtendedType
)]
TypeDB
->
TypeDB
findFunction
::
FunctionName
TypeDB
->
[(
FunctionLocation
,
ExtendedType
)]
findFunction`
::
(
FunctionLocation
ExtendedType
->
Bool
)
TypeDB
->
[(
FunctionLocation
,
ExtendedType
)]
findFunction``
::
[(
FunctionLocation
ExtendedType
->
Bool
)]
TypeDB
->
[(
FunctionLocation
,
ExtendedType
)]
getMacro
::
MacroLocation
TypeDB
->
Maybe
Macro
putMacro
::
MacroLocation
Macro
TypeDB
->
TypeDB
putMacros
::
[(
MacroLocation
,
Macro
)]
TypeDB
->
TypeDB
findMacro`
::
(
MacroLocation
Macro
->
Bool
)
TypeDB
->
[(
MacroLocation
,
Macro
)]
instance
print
(
Name
,
ExtendedType
)
getName
::
Location
->
Name
getFunction
::
Location
TypeDB
->
Maybe
ExtendedType
putFunction
::
Location
ExtendedType
TypeDB
->
TypeDB
putFunctions
::
[(
Location
,
ExtendedType
)]
TypeDB
->
TypeDB
findFunction
::
Name
TypeDB
->
[(
Location
,
ExtendedType
)]
findFunction`
::
(
Location
ExtendedType
->
Bool
)
TypeDB
->
[(
Location
,
ExtendedType
)]
findFunction``
::
[(
Location
ExtendedType
->
Bool
)]
TypeDB
->
[(
Location
,
ExtendedType
)]
getMacro
::
Location
TypeDB
->
Maybe
Macro
putMacro
::
Location
Macro
TypeDB
->
TypeDB
putMacros
::
[(
Location
,
Macro
)]
TypeDB
->
TypeDB
findMacro`
::
(
Location
Macro
->
Bool
)
TypeDB
->
[(
Location
,
Macro
)]
getInstances
::
Class
TypeDB
->
[
Type
]
putInstance
::
Class
Type
TypeDB
->
TypeDB
putInstances
::
Class
[
Type
]
TypeDB
->
TypeDB
putInstancess
::
[(
Class
,
[
Type
])]
TypeDB
->
TypeDB
getClass
::
ClassLocation
TypeDB
->
Maybe
([
TypeVar
],
ClassContext
,[(
FunctionName
,
ExtendedType
)])
putClass
::
ClassLocation
[
TypeVar
]
ClassContext
[(
FunctionName
,
ExtendedType
)]
TypeDB
->
TypeDB
putClasses
::
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
FunctionName
,
ExtendedType
)])]
TypeDB
->
TypeDB
findClass
::
Class
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
FunctionName
,
ExtendedType
)])]
findClass`
::
(
ClassLocation
[
TypeVar
]
ClassContext
[(
FunctionName
,
ExtendedType
)]
->
Bool
)
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
FunctionName
,
ExtendedType
)])]
findClassMembers`
::
(
ClassLocation
[
TypeVar
]
ClassContext
FunctionName
ExtendedType
->
Bool
)
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
FunctionName
,
ExtendedType
)]
findClassMembers``
::
[
ClassLocation
[
TypeVar
]
ClassContext
FunctionName
ExtendedType
->
Bool
]
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
FunctionName
,
ExtendedType
)]
getType
::
TypeLocation
TypeDB
->
Maybe
TypeDef
putType
::
TypeLocation
TypeDef
TypeDB
->
TypeDB
putTypes
::
[(
TypeLocation
,
TypeDef
)]
TypeDB
->
TypeDB
findType
::
TypeName
TypeDB
->
[(
TypeLocation
,
TypeDef
)]
findType`
::
(
TypeLocation
TypeDef
->
Bool
)
TypeDB
->
[(
TypeLocation
,
TypeDef
)]
getDerivations
::
GenericName
TypeDB
->
[
Type
]
putDerivation
::
GenericName
Type
TypeDB
->
TypeDB
putDerivations
::
GenericName
[
Type
]
TypeDB
->
TypeDB
putDerivationss
::
[(
GenericName
,
[
Type
])]
TypeDB
->
TypeDB
searchExact
::
Type
TypeDB
->
[(
FunctionLocation
,
ExtendedType
)]
getClass
::
Location
TypeDB
->
Maybe
([
TypeVar
],
ClassContext
,[(
Name
,
ExtendedType
)])
putClass
::
Location
[
TypeVar
]
ClassContext
[(
Name
,
ExtendedType
)]
TypeDB
->
TypeDB
putClasses
::
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
TypeDB
->
TypeDB
findClass
::
Class
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
findClass`
::
(
Location
[
TypeVar
]
ClassContext
[(
Name
,
ExtendedType
)]
->
Bool
)
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
findClassMembers`
::
(
Location
[
TypeVar
]
ClassContext
Name
ExtendedType
->
Bool
)
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
Name
,
ExtendedType
)]
findClassMembers``
::
[
Location
[
TypeVar
]
ClassContext
Name
ExtendedType
->
Bool
]
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
Name
,
ExtendedType
)]
getType
::
Location
TypeDB
->
Maybe
TypeDef
putType
::
Location
TypeDef
TypeDB
->
TypeDB
putTypes
::
[(
Location
,
TypeDef
)]
TypeDB
->
TypeDB
findType
::
Name
TypeDB
->
[(
Location
,
TypeDef
)]
findType`
::
(
Location
TypeDef
->
Bool
)
TypeDB
->
[(
Location
,
TypeDef
)]
getDerivations
::
Name
TypeDB
->
[
Type
]
putDerivation
::
Name
Type
TypeDB
->
TypeDB
putDerivations
::
Name
[
Type
]
TypeDB
->
TypeDB
putDerivationss
::
[(
Name
,
[
Type
])]
TypeDB
->
TypeDB
searchExact
::
Type
TypeDB
->
[(
Location
,
ExtendedType
)]
newDb
::
TypeDB
openDb
::
*
File
->
*(
Maybe
TypeDB
,
*
File
)
...
...
backend/TypeDB.icl
View file @
4cf0b6c4
...
...
@@ -13,12 +13,12 @@ import Text.JSON
import
Type
::
TypeDB
=
{
functionmap
::
Map
Function
Location
ExtendedType
,
macromap
::
Map
Macro
Location
Macro
,
classmap
::
Map
ClassLocation
([
TypeVar
],
ClassContext
,[(
Function
Name
,
ExtendedType
)])
=
{
functionmap
::
Map
Location
ExtendedType
,
macromap
::
Map
Location
Macro
,
classmap
::
Map
Location
([
TypeVar
],
ClassContext
,[(
Name
,
ExtendedType
)])
,
instancemap
::
Map
Class
[
Type
]
,
typemap
::
Map
Type
Location
TypeDef
,
derivemap
::
Map
Generic
Name
[
Type
]
,
typemap
::
Map
Location
TypeDef
,
derivemap
::
Map
Name
[
Type
]
}
printersperse
::
Bool
a
[
b
]
->
[
String
]
|
print
a
&
print
b
...
...
@@ -27,15 +27,14 @@ printersperse ia a bs = intercalate (print False a) (map (print ia) bs)
(--)
infixr
5
::
a
b
->
[
String
]
|
print
a
&
print
b
(--)
a
b
=
print
False
a
++
print
False
b
derive
gEq
ClassOrGeneric
,
FunctionLocation
,
ClassLocation
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeLocation
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
MacroLocation
,
Macro
derive
JSONEncode
ClassOrGeneric
,
FunctionLocation
,
ClassLocation
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeLocation
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
MacroLocation
,
Macro
derive
JSONDecode
ClassOrGeneric
,
FunctionLocation
,
ClassLocation
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeLocation
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
MacroLocation
,
Macro
derive
gEq
ClassOrGeneric
,
Location
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
Macro
derive
JSONEncode
ClassOrGeneric
,
Location
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
Macro
derive
JSONDecode
ClassOrGeneric
,
Location
,
Type
,
TypeDB
,
TypeExtras
,
TE_Priority
,
ExtendedType
,
TypeDef
,
TypeDefRhs
,
RecordField
,
Constructor
,
Kind
,
Macro
instance
zero
TypeDB
where
...
...
@@ -47,35 +46,18 @@ where
,
derivemap
=
newMap
}
instance
<
(
a
,
b
,
c
,
d
)
|
Ord
a
&
Ord
b
&
Ord
c
&
Ord
d
where
(<)
(
a
,
b
,
c
,
d
)
(
e
,
f
,
g
,
h
)
=
((
a
,
b
),(
c
,
d
))
<
((
e
,
f
),(
g
,
h
))
instance
<
(
Maybe
a
)
|
<
a
where
(<)
(
Just
a
)
(
Just
b
)
=
a
<
b
(<)
(
Just
_)
Nothing
=
True
(<)
Nothing
_
=
False
instance
<
Function
Location
instance
<
Location
where
(<)
(
FL
a
b
c
d
)
(
FL
e
f
g
h
)
=
(
a
,
b
,
c
,
d
)
<
(
e
,
f
,
g
,
h
)
(<)
(
FL_Builtin
a
)
(
FL_Builtin
b
)
=
a
<
b
(<)
(
FL_Builtin
_)
_
=
True
(<)
_
_
=
False
instance
<
MacroLocation
where
(<)
(
ML
a
b
c
d
)
(
ML
e
f
g
h
)
=
(
a
,
b
,
c
,
d
)
<
(
e
,
f
,
g
,
h
)
instance
<
ClassLocation
where
(<)
(
CL
a
b
c
d
)
(
CL
e
f
g
h
)
=
(
a
,
b
,
c
,
d
)
<
(
e
,
f
,
g
,
h
)
instance
<
TypeLocation
where
(<)
(
TL
a
b
c
d
)
(
TL
e
f
g
h
)
=
(
a
,
b
,
c
,
d
)
<
(
e
,
f
,
g
,
h
)
(<)
(
TL_Builtin
a
)
(
TL_Builtin
b
)
=
a
<
b
(<)
(
TL_Builtin
_)
_
=
True
(<)
_
_
=
False
(<)
(
Location
a
b
c
d
)
(
Location
e
f
g
h
)
=
((
a
,
b
),(
c
,
d
))
<
((
e
,
f
),(
g
,
h
))
(<)
(
Location
_
_
_
_)
(
Builtin
_)
=
True
(<)
(
Builtin
_)
(
Location
_
_
_
_)
=
False
(<)
(
Builtin
a
)
(
Builtin
b
)
=
a
<
b
instance
zero
TypeExtras
where
...
...
@@ -97,7 +79,7 @@ where
print
_
(
RightAssoc
i
)
=
"infixr "
--
i
print
_
(
NoAssoc
i
)
=
"infix "
--
i
instance
print
(
Function
Name
,
ExtendedType
)
instance
print
(
Name
,
ExtendedType
)
where
print
_
(
f
,
(
ET
t
e
))
=
gen
--
fname
--
" "
--
e
--
" :: "
--
t
...
...
@@ -108,40 +90,41 @@ where
|
e
.
te_isrecordfield
=
"."
+++
f
|
otherwise
=
f
getFunction
::
FunctionLocation
TypeDB
->
Maybe
ExtendedType
getName
::
Location
->
Name
getName
(
Location
_
_
_
name
)
=
name
getName
(
Builtin
name
)
=
name
getFunction
::
Location
TypeDB
->
Maybe
ExtendedType
getFunction
loc
{
functionmap
}
=
get
loc
functionmap
putFunction
::
Function
Location
ExtendedType
TypeDB
->
TypeDB
putFunction
::
Location
ExtendedType
TypeDB
->
TypeDB
putFunction
fl
t
tdb
=:{
functionmap
}
=
{
tdb
&
functionmap
=
put
fl
t
functionmap
}
putFunctions
::
[(
Function
Location
,
ExtendedType
)]
TypeDB
->
TypeDB
putFunctions
::
[(
Location
,
ExtendedType
)]
TypeDB
->
TypeDB
putFunctions
ts
tdb
=
foldr
(\(
loc
,
t
)
db
->
putFunction
loc
t
db
)
tdb
ts
findFunction
::
FunctionName
TypeDB
->
[(
Function
Location
,
ExtendedType
)]
findFunction
::
Name
TypeDB
->
[(
Location
,
ExtendedType
)]
findFunction
f
db
=:{
functionmap
}
=
toList
$
filterWithKey
(\
fl
_->
f
==
getName
fl
)
functionmap
where
getName
(
FL
_
_
f
_)
=
f
getName
(
FL_Builtin
f
)
=
f
findFunction`
::
(
Function
Location
ExtendedType
->
Bool
)
TypeDB
->
[(
Function
Location
,
ExtendedType
)]
findFunction`
::
(
Location
ExtendedType
->
Bool
)
TypeDB
->
[(
Location
,
ExtendedType
)]
findFunction`
f
{
functionmap
}
=
toList
$
filterWithKey
f
functionmap
findFunction``
::
[(
Function
Location
ExtendedType
->
Bool
)]
TypeDB
->
[(
Function
Location
,
ExtendedType
)]
findFunction``
::
[(
Location
ExtendedType
->
Bool
)]
TypeDB
->
[(
Location
,
ExtendedType
)]
findFunction``
fs
{
functionmap
}
=
toList
$
foldr
filterWithKey
functionmap
fs
getMacro
::
Macro
Location
TypeDB
->
Maybe
Macro
getMacro
::
Location
TypeDB
->
Maybe
Macro
getMacro
loc
{
macromap
}
=
get
loc
macromap
putMacro
::
Macro
Location
Macro
TypeDB
->
TypeDB
putMacro
::
Location
Macro
TypeDB
->
TypeDB
putMacro
ml
m
db
=:{
macromap
}
=
{
db
&
macromap
=
put
ml
m
macromap
}
putMacros
::
[(
Macro
Location
,
Macro
)]
TypeDB
->
TypeDB
putMacros
::
[(
Location
,
Macro
)]
TypeDB
->
TypeDB
putMacros
ms
db
=
foldr
(\(
loc
,
m
)
db
->
putMacro
loc
m
db
)
db
ms
findMacro`
::
(
MacroLocation
Macro
->
Bool
)
TypeDB
->
[(
Macro
Location
,
Macro
)]
findMacro`
::
(
Location
Macro
->
Bool
)
TypeDB
->
[(
Location
,
Macro
)]
findMacro`
f
{
macromap
}
=
toList
$
filterWithKey
f
macromap
getInstances
::
Class
TypeDB
->
[
Type
]
...
...
@@ -158,71 +141,68 @@ putInstances c ts db = foldr (\t db -> putInstance c t db) db ts
putInstancess
::
[(
Class
,
[
Type
])]
TypeDB
->
TypeDB
putInstancess
is
db
=
foldr
(\(
c
,
ts
)
db
->
putInstances
c
ts
db
)
db
is
getClass
::
ClassLocation
TypeDB
->
Maybe
([
TypeVar
],
ClassContext
,[(
Function
Name
,
ExtendedType
)])
getClass
::
Location
TypeDB
->
Maybe
([
TypeVar
],
ClassContext
,[(
Name
,
ExtendedType
)])
getClass
loc
{
classmap
}
=
get
loc
classmap
putClass
::
ClassLocation
[
TypeVar
]
ClassContext
[(
Function
Name
,
ExtendedType
)]
TypeDB
->
TypeDB
putClass
::
Location
[
TypeVar
]
ClassContext
[(
Name
,
ExtendedType
)]
TypeDB
->
TypeDB
putClass
cl
tvs
cc
fs
db
=:{
classmap
}
=
{
db
&
classmap
=
put
cl
(
tvs
,
cc
,
fs
)
classmap
}
putClasses
::
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
Function
Name
,
ExtendedType
)])]
TypeDB
->
TypeDB
putClasses
::
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
TypeDB
->
TypeDB
putClasses
cs
db
=
foldr
(\(
cl
,
tvs
,
cc
,
fs
)
db
->
putClass
cl
tvs
cc
fs
db
)
db
cs
findClass
::
Class
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
Function
Name
,
ExtendedType
)])]
findClass
::
Class
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
findClass
c
{
classmap
}
=
map
(\(
k
,(
x
,
y
,
z
))->(
k
,
x
,
y
,
z
))
results
where
results
=
toList
$
filterWithKey
(\(
CL
_
_
c`
_
)
_->
c
==
c`
)
classmap
where
results
=
toList
$
filterWithKey
(\(
Location
_
_
_
c`
)
_->
c
==
c`
)
classmap
findClass`
::
(
ClassLocation
[
TypeVar
]
ClassContext
[(
Function
Name
,
ExtendedType
)]
->
Bool
)
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
[(
Function
Name
,
ExtendedType
)])]
findClass`
::
(
Location
[
TypeVar
]
ClassContext
[(
Name
,
ExtendedType
)]
->
Bool
)
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
[(
Name
,
ExtendedType
)])]
findClass`
f
{
classmap
}
=
map
(\(
k
,(
x
,
y
,
z
))->(
k
,
x
,
y
,
z
))
results
where
results
=
toList
$
filterWithKey
(\
cl
(
vs
,
cc
,
fs
)->
f
cl
vs
cc
fs
)
classmap
findClassMembers`
::
(
ClassLocation
[
TypeVar
]
ClassContext
Function
Name
ExtendedType
->
Bool
)
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
Function
Name
,
ExtendedType
)]
findClassMembers`
::
(
Location
[
TypeVar
]
ClassContext
Name
ExtendedType
->
Bool
)
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
Name
,
ExtendedType
)]
findClassMembers`
f
{
classmap
}
=
filter
(
app5
f
)
$
flatten
members
where
members
=
map
(\(
cl
,(
vs
,
cc
,
fs
))->[(
cl
,
vs
,
cc
,
f
,
t
)
\\
(
f
,
t
)<-
fs
])
$
toList
classmap
findClassMembers``
::
[(
ClassLocation
[
TypeVar
]
ClassContext
Function
Name
ExtendedType
->
Bool
)]
TypeDB
->
[(
ClassLocation
,
[
TypeVar
],
ClassContext
,
Function
Name
,
ExtendedType
)]
findClassMembers``
::
[(
Location
[
TypeVar
]
ClassContext
Name
ExtendedType
->
Bool
)]
TypeDB
->
[(
Location
,
[
TypeVar
],
ClassContext
,
Name
,
ExtendedType
)]
findClassMembers``
fs
{
classmap
}
=
foldr
(
filter
o
app5
)
all_members
fs
where
all_members
=
[(
cl
,
vs
,
cc
,
f
,
t
)
\\
(
cl
,(
vs
,
cc
,
fs
))
<-
toList
classmap
,
(
f
,
t
)
<-
fs
]
getType
::
Type
Location
TypeDB
->
Maybe
TypeDef
getType
::
Location
TypeDB
->
Maybe
TypeDef
getType
loc
{
typemap
}
=
get
loc
typemap
putType
::
Type
Location
TypeDef
TypeDB
->
TypeDB
putType
::
Location
TypeDef
TypeDB
->
TypeDB
putType
tl
td
db
=:{
typemap
}
=
{
db
&
typemap
=
put
tl
td
typemap
}
putTypes
::
[(
Type
Location
,
TypeDef
)]
TypeDB
->
TypeDB
putTypes
::
[(
Location
,
TypeDef
)]
TypeDB
->
TypeDB
putTypes
ts
db
=
foldr
(\(
loc
,
td
)
->
putType
loc
td
)
db
ts
findType
::
TypeName
TypeDB
->
[(
Type
Location
,
TypeDef
)]
findType
::
Name
TypeDB
->
[(
Location
,
TypeDef
)]
findType
t
db
=:{
typemap
}
=
toList
$
filterWithKey
(\
tl
_
->
getName
tl
==
t
)
typemap
where
getName
(
TL
_
_
t
_)
=
t
getName
(
TL_Builtin
t
)
=
t
findType`
::
(
Type
Location
TypeDef
->
Bool
)
TypeDB
->
[(
Type
Location
,
TypeDef
)]
findType`
::
(
Location
TypeDef
->
Bool
)
TypeDB
->
[(
Location
,
TypeDef
)]
findType`
f
{
typemap
}
=
toList
$
filterWithKey
f
typemap
getDerivations
::
Generic
Name
TypeDB
->
[
Type
]
getDerivations
::
Name
TypeDB
->
[
Type
]
getDerivations
gen
{
derivemap
}
=
if
(
isNothing
ts
)
[]
(
fromJust
ts
)
where
ts
=
get
gen
derivemap
putDerivation
::
Generic
Name
Type
TypeDB
->
TypeDB
putDerivation
::
Name
Type
TypeDB
->
TypeDB
putDerivation
gen
t
db
=:{
derivemap
}
=
{
db
&
derivemap
=
put
gen
ts
derivemap
}
where
ts
=
removeDup
[
t
:
getDerivations
gen
db
]
putDerivations
::
Generic
Name
[
Type
]
TypeDB
->
TypeDB
putDerivations
::
Name
[
Type
]
TypeDB
->
TypeDB
putDerivations
gen
ts
db
=
foldr
(\
t
db
->
putDerivation
gen
t
db
)
db
ts
putDerivationss
::
[(
Generic
Name
,
[
Type
])]
TypeDB
->
TypeDB
putDerivationss
::
[(
Name
,
[
Type
])]
TypeDB
->
TypeDB
putDerivationss
ds
db
=
foldr
(\(
g
,
ts
)
db
->
putDerivations
g
ts
db
)
db
ds
searchExact
::
Type
TypeDB
->
[(
Function
Location
,
ExtendedType
)]
searchExact
::
Type
TypeDB
->
[(
Location
,
ExtendedType
)]
searchExact
t
db
=
filter
((\(
ET
t`
_)->
t
==
t`
)
o
snd
)
$
toList
db
.
functionmap
newDb
::
TypeDB
...
...
backend/builddb.icl
View file @
4cf0b6c4
...
...
@@ -23,7 +23,6 @@ import CoclUtils
import
CleanPrettyPrint
// frontend
//import Heap, compile, parse, predef
import
Heap
from
hashtable
import
::
HashTable
,
::
QualifiedIdents
(
NoQualifiedIdents
),
::
IdentClass
(
IC_Module
),
::
BoxedIdent
{..},
putIdentInHashTable
...
...
@@ -101,16 +100,16 @@ Start w
#
(
ok
,
w
)
=
case
parseCLI
(
tl
args
)
of
(
Left
e
)
=
fclose
(
f
<<<
e
)
w
(
Right
cli
)
|
cli
.
help
=
fclose
(
f
<<<
USAGE
)
w
|
cli
.
help
=
fclose
(
f
<<<
USAGE
)
w
|
cli
.
version
=
fclose
(
f
<<<
VERSION
)
w
#
(
modss
,
w
)
=
mapSt
(\
l
->
findModules
cli
.
exclude
cli
.
root
l
""
)
cli
.
libs
w
#
mods
=
flatten
modss
#
(
st
,
w
)
=
init_identifiers
newHeap
w