Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
H
hal
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
3
Issues
3
List
Board
Labels
Milestones
Merge Requests
2
Merge Requests
2
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
crawlers
hal
Commits
af3ee73e
Verified
Commit
af3ee73e
authored
Jul 24, 2023
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[refactoring] remove stack.yaml, add Protolude, migrate to cabal
parent
7b740eee
Changes
13
Hide whitespace changes
Inline
Side-by-side
Showing
13 changed files
with
206 additions
and
318 deletions
+206
-318
.gitignore
.gitignore
+1
-0
Main.hs
app/Main.hs
+8
-8
cabal.project
cabal.project
+10
-0
crawlerHAL.cabal
crawlerHAL.cabal
+62
-48
package.yaml
package.yaml
+0
-72
HAL.hs
src/HAL.hs
+51
-42
Client.hs
src/HAL/Client.hs
+8
-12
Doc.hs
src/HAL/Doc.hs
+4
-1
Corpus.hs
src/HAL/Doc/Corpus.hs
+14
-16
EntityTree.hs
src/HAL/Doc/EntityTree.hs
+9
-12
Struct.hs
src/HAL/Doc/Struct.hs
+7
-10
Tree.hs
src/Tree.hs
+32
-32
stack.yaml
stack.yaml
+0
-65
No files found.
.gitignore
View file @
af3ee73e
dist-newstyle/
.stack-work/
*~
app/Main.hs
View file @
af3ee73e
...
...
@@ -3,17 +3,18 @@
module
Main
where
import
Data.LanguageCodes
(
ISO639_1
(
..
))
import
Data.Text
qualified
as
T
import
HAL
import
HAL
(
getMetadataWith
)
import
HAL.Client
import
HAL.Doc
import
NeatInterpolation
(
text
)
import
Network.HTTP.Client
(
newManager
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Protolude
import
Servant.Client
import
HAL
(
getMetadataWith
)
import
HAL.Client
import
HAL.Doc
import
HAL
import
Tree
import
qualified
Data.Text
as
T
yearReq
=
[
text
|
...
...
@@ -64,8 +65,7 @@ imt = [
main
::
IO
()
main
=
do
-- res <- getMetadataWith (generateRequestByStructID "artificial intelligence" imt) (Just 0) (Just 55)
res
<-
getMetadataWith
(
generateRequestByStructID
"artificial intelligence"
imt
)
(
Just
0
)
(
Just
55
)
res
<-
getMetadataWith
(
generateRequestByStructID
"artificial intelligence"
imt
)
(
Just
0
)
(
Just
55
)
(
Just
EN
)
case
res
of
(
Left
err
)
->
print
err
(
Right
val
)
->
print
$
_docs
val
cabal.project
0 → 100644
View file @
af3ee73e
-- Generated by stack2cabal
with-compiler: ghc-9.2.8
packages:
./
allow-older: *
allow-newer: *
crawlerHAL.cabal
View file @
af3ee73e
...
...
@@ -24,6 +24,7 @@ source-repository head
location: https://git@gitlab.iscpif.fr:20022/gargantext/crawlers/hal
library
ghc-options: -Wall -Werror
exposed-modules:
HAL
HAL.Client
...
...
@@ -39,28 +40,33 @@ library
default-extensions:
DataKinds
DeriveGeneric
ImportQualifiedPost
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RecordWildCards
TypeOperators
build-depends:
aeson
aeson
>= 2.1.0 && < 2.3
, base >=4.7 && <5
, bytestring
, conduit
, containers
, data-default
, http-client
, http-client-tls
, lens
, neat-interpolation
, scientific
, servant
, servant-client
, split
, text
, utf8-string
, vector
, bytestring >= 0.11.0 && < 0.13
, conduit >= 1.3.5 && < 1.4
, containers >= 0.6.7 && < 0.7
, data-default >= 0.7.1.1 && < 0.8
, http-client >= 0.7.13.1 && < 0.8
, http-client-tls >= 0.3.6.2 && < 0.4
, iso639 >= 0.1.0.3 && < 0.2
, lens >= 5.2.2 && < 5.3
, neat-interpolation >= 0.5.1.3 && < 0.6
, protolude >= 0.3.3 && < 0.4
, scientific >= 0.3.7.0 && < 0.4
, servant >= 0.19 && < 0.21
, servant-client >= 0.19 && < 0.21
, split >= 0.2.3.5 && < 0.3
, text >= 2.0.2 && < 2.1
, text-format >= 0.3.2.1 && < 0.4
, utf8-string >= 1.0.2 && < 1.1
, vector >= 0.13.0 && < 0.14
default-language: Haskell2010
executable crawlerHAL-exe
...
...
@@ -72,30 +78,34 @@ executable crawlerHAL-exe
default-extensions:
DataKinds
DeriveGeneric
ImportQualifiedPost
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RecordWildCards
TypeOperators
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
aeson
aeson
>= 2.1.0 && < 2.3
, base >=4.7 && <5
, bytestring
, conduit
, containers
, bytestring
>= 0.11.0 && < 0.13
, conduit
>= 1.3.5 && < 1.4
, containers
>= 0.6.7 && < 0.7
, crawlerHAL
, data-default
, http-client
, http-client-tls
, lens
, neat-interpolation
, scientific
, servant
, servant-client
, split
, text
, utf8-string
, vector
, data-default >= 0.7.1.1 && < 0.8
, http-client >= 0.7.13.1 && < 0.8
, http-client-tls >= 0.3.6.2 && < 0.4
, iso639 >= 0.1.0.3 && < 0.2
, lens >= 5.2.2 && < 5.3
, neat-interpolation >= 0.5.1.3 && < 0.6
, protolude >= 0.3.3 && < 0.4
, scientific >= 0.3.7.0 && < 0.4
, servant >= 0.19 && < 0.21
, servant-client >= 0.19 && < 0.21
, split >= 0.2.3.5 && < 0.3
, text >= 2.0.2 && < 2.1
, utf8-string >= 1.0.2 && < 1.1
, vector >= 0.13.0 && < 0.14
default-language: Haskell2010
test-suite halCrawler-test
...
...
@@ -108,28 +118,32 @@ test-suite halCrawler-test
default-extensions:
DataKinds
DeriveGeneric
ImportQualifiedPost
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RecordWildCards
TypeOperators
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
aeson
aeson
>= 2.1.0 && < 2.3
, base >=4.7 && <5
, bytestring
, conduit
, containers
, data-default
, bytestring
>= 0.11.0 && < 0.13
, conduit
>= 1.3.5 && < 1.4
, containers
>= 0.6.7 && < 0.7
, data-default
>= 0.7.1.1 && < 0.8
, halCrawler
, http-client
, http-client-tls
, lens
, neat-interpolation
, scientific
, servant
, servant-client
, split
, text
, utf8-string
, vector
, http-client >= 0.7.13.1 && < 0.8
, http-client-tls >= 0.3.6.2 && < 0.4
, iso639 >= 0.1.0.3 && < 0.2
, lens >= 5.2.2 && < 5.3
, neat-interpolation >= 0.5.1.3 && < 0.6
, protolude >= 0.3.3 && < 0.4
, scientific >= 0.3.7.0 && < 0.4
, servant >= 0.19 && < 0.21
, servant-client >= 0.19 && < 0.21
, split >= 0.2.3.5 && < 0.3
, text >= 2.0.2 && < 2.1
, utf8-string >= 1.0.2 && < 1.1
, vector >= 0.13.0 && < 0.14
default-language: Haskell2010
package.yaml
deleted
100644 → 0
View file @
7b740eee
name
:
crawlerHAL
version
:
0.1.0.0
git
:
"
https://git@gitlab.iscpif.fr:20022/gargantext/crawlers/hal"
license
:
BSD3
author
:
"
CNRS/IMT"
maintainer
:
"
contact@gargantext.org"
copyright
:
"
2019
CNRS/IMT"
extra-source-files
:
-
README.md
-
ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description
:
Please see the README at <https://git@gitlab.iscpif.fr:20022/gargantext/crawlers/hal>
dependencies
:
-
aeson
-
base >= 4.7 && < 5
-
bytestring
-
conduit
-
containers
-
data-default
-
http-client
-
http-client-tls
-
lens
-
neat-interpolation
-
scientific
-
servant
-
servant-client
-
split
-
text
-
utf8-string
-
vector
library
:
source-dirs
:
src
default-extensions
:
-
DataKinds
-
DeriveGeneric
-
NamedFieldPuns
-
OverloadedStrings
-
RecordWildCards
-
TypeOperators
executables
:
crawlerHAL-exe
:
main
:
Main.hs
source-dirs
:
app
ghc-options
:
-
-threaded
-
-rtsopts
-
-with-rtsopts=-N
dependencies
:
-
crawlerHAL
tests
:
halCrawler-test
:
main
:
Spec.hs
source-dirs
:
test
ghc-options
:
-
-threaded
-
-rtsopts
-
-with-rtsopts=-N
dependencies
:
-
halCrawler
src/HAL.hs
View file @
af3ee73e
module
HAL
where
import
Conduit
import
Data.Default
(
def
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Either
(
fromRight
)
import
Data.Aeson
import
Data.LanguageCodes
(
ISO639_1
(
..
))
import
Data.Text
import
Network.HTTP.Client
(
newManager
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
..
),
ClientM
,
ClientError
,
runClientM
,
mkClientEnv
)
import
HAL.Client
import
HAL.Doc.Corpus
import
HAL.Doc.Struct
import
Network.HTTP.Client
(
newManager
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Protolude
import
Servant.API
import
Data.Aeson
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
..
),
ClientM
,
ClientError
,
runClientM
,
mkClientEnv
)
batchSize
::
Int
batchSize
=
1000
getMetadataWith
::
Text
->
Maybe
Int
->
Maybe
Integer
->
IO
(
Either
ClientError
(
Response
Corpus
))
getMetadataWith
q
start
rows
=
do
manager'
<-
newManager
tlsManagerSettings
runHalAPIClient
$
search
(
Just
requestedFields
)
[
q
]
Nothing
start
rows
getMetadataWithC
::
Text
->
Maybe
Int
->
Maybe
Integer
->
IO
(
Either
ClientError
(
Maybe
Integer
,
ConduitT
()
Corpus
IO
()
))
getMetadataWithC
q
start
rows
=
do
manager'
<-
newManager
tlsManagerSettings
type
Query
=
Text
type
Start
=
Int
type
Limit
=
Integer
type
Count
=
Integer
getMetadataWith
::
Query
->
Maybe
Start
->
Maybe
Limit
->
Maybe
ISO639_1
->
IO
(
Either
ClientError
(
Response
Corpus
))
getMetadataWith
q
start_
limit
lang
=
do
runHalAPIClient
$
search
(
Just
$
requestedFields
lang
)
[
q
]
Nothing
start_
limit
getMetadataWithC
::
Query
->
Maybe
Start
->
Maybe
Limit
->
Maybe
ISO639_1
->
IO
(
Either
ClientError
(
Maybe
Count
,
ConduitT
()
Corpus
IO
()
))
getMetadataWithC
q
start_
limit
lang
=
do
-- First, estimate the total number of documents
eCount
<-
countResults
q
pure
$
get'
q
start
rows
<$>
eCount
pure
$
get'
<$>
eCount
where
get'
::
Text
->
Maybe
Int
->
Maybe
Integer
->
Integer
->
(
Maybe
Integer
,
ConduitT
()
Corpus
IO
()
)
get'
q
start
rows
numFound
=
get'
::
Count
->
(
Maybe
Count
,
ConduitT
()
Corpus
IO
()
)
get'
numFound_
=
(
Just
numResults
,
yieldMany
[
0
..
]
.|
takeC
(
fromInteger
numPages
)
.|
concatMapMC
(
getPage
q
start'
))
.|
concatMapMC
(
getPage
start'
))
where
start'
=
fromMaybe
0
start
rows'
=
min
numFound
$
fromMaybe
numFound
rows
start'
=
fromMaybe
0
start
_
rows'
=
min
numFound
_
$
fromMaybe
numFound_
limit
numResults
=
rows'
-
(
fromIntegral
start'
)
numPages
=
numResults
`
div
`
(
fromIntegral
batchSize
)
+
1
getPage
::
Text
->
In
t
->
Int
->
IO
[
Corpus
]
getPage
q
start
pageNum
=
do
let
offset
=
start
+
pageNum
*
batchSize
eRes
<-
runHalAPIClient
$
search
(
Just
requestedFields
)
[
q
]
Nothing
(
Just
offset
)
(
Just
$
fromIntegral
batchSize
)
getPage
::
Star
t
->
Int
->
IO
[
Corpus
]
getPage
start'
pageNum
=
do
let
offset
=
start
'
+
pageNum
*
batchSize
eRes
<-
runHalAPIClient
$
search
(
Just
$
requestedFields
lang
)
[
q
]
Nothing
(
Just
offset
)
(
Just
$
fromIntegral
batchSize
)
pure
$
case
eRes
of
Left
_
->
[]
Right
(
Response
{
_docs
})
->
_docs
printDoc
::
Corpus
->
IO
Corpus
printDoc
c
@
(
Corpus
{
_corpus_docid
,
_corpus_title
})
=
do
prin
t
$
show
_corpus_title
pure
c
--
printDoc :: Corpus -> IO Corpus
-- printDoc c@(Corpus { ..
}) = do
-- putTex
t $ show _corpus_title
--
pure c
countResults
::
Text
->
IO
(
Either
ClientError
Integer
)
countResults
::
Query
->
IO
(
Either
ClientError
Count
)
countResults
q
=
do
manager'
<-
newManager
tlsManagerSettings
-- First, estimate the total number of documents
eRes
<-
runHalAPIClient
$
search
(
Just
requestedFields
)
[
q
]
Nothing
(
Just
0
)
(
Just
1
)
::
IO
(
Either
ClientError
(
Response
Corpus
))
eRes
<-
runHalAPIClient
$
search
(
Just
$
requestedFields
Nothing
)
[
q
]
Nothing
(
Just
0
)
(
Just
1
)
::
IO
(
Either
ClientError
(
Response
Corpus
))
pure
$
_numFound
<$>
eRes
requestedFields
::
Text
requestedFields
=
"docid,title_s,abstract_s,submittedDate_s,source_s,authFullName_s,authOrganism_s"
requestedFields
::
Maybe
ISO639_1
->
Text
requestedFields
(
Just
EN
)
=
"docid,title_s,en_abstract_s,submittedDate_s,source_s,authFullName_s,authOrganism_s"
requestedFields
(
Just
FR
)
=
"docid,title_s,en_abstract_s,fr_abstract_s,submittedDate_s,source_s,authFullName_s,authOrganism_s"
requestedFields
_
=
requestedFields
(
Just
EN
)
structFields
::
Text
structFields
=
"docid,label_s,parentDocid_i"
...
...
@@ -80,9 +88,9 @@ runStructureRequest :: Maybe Text -> IO (Either ClientError (Response Struct))
runStructureRequest
rq
=
runHalAPIClient
$
structure
(
Just
structFields
)
rq
(
Just
10000
)
runSearchRequest
::
[
Text
]
->
IO
(
Either
ClientError
(
Response
Corpus
))
runSearchRequest
rq
=
runHalAPIClient
$
search
(
Just
requestedFields
)
rq
Nothing
Nothing
Nothing
runSearchRequest
::
[
Text
]
->
Maybe
ISO639_1
->
IO
(
Either
ClientError
(
Response
Corpus
))
runSearchRequest
rq
lang
=
runHalAPIClient
$
search
(
Just
$
requestedFields
lang
)
rq
Nothing
Nothing
Nothing
generateRequestByStructID
::
Text
->
[
Text
]
->
Text
generateRequestByStructID
rq
struct_ids
=
...
...
@@ -94,5 +102,6 @@ generateRequestByStructID rq struct_ids =
<>
")"
flattenPipe
::
[
Text
]
->
Text
flattenPipe
[]
=
""
flattenPipe
(
x
:
[]
)
=
x
flattenPipe
(
x
:
xs
)
=
x
<>
" || "
<>
flattenPipe
xs
src/HAL/Client.hs
View file @
af3ee73e
...
...
@@ -3,18 +3,13 @@
module
HAL.Client
where
import
Control.Lens
as
L
(
makeLenses
)
import
Data.Aeson
import
Data.Proxy
import
GHC.Generics
import
Protolude
import
Servant.API
import
Servant.Client
hiding
(
Response
)
import
Data.Text
import
Data.Map
import
Data.Aeson
import
qualified
Data.ByteString.Lazy
as
BSL
import
qualified
Codec.Binary.UTF8.String
as
UTF
import
Control.Lens
as
L
(
makeLenses
)
type
HALAPI
doc
=
Search
doc
:<|>
Structure
doc
...
...
@@ -62,10 +57,11 @@ data Response doc = Response
L
.
makeLenses
''
R
esponse
instance
FromJSON
doc
=>
FromJSON
(
Response
doc
)
where
parseJSON
(
Object
o
)
=
Response
<$>
((
o
.:
"response"
)
>>=
(
.:
"numFound"
))
<*>
((
o
.:
"response"
)
>>=
(
.:
"start"
))
<*>
((
o
.:
"response"
)
>>=
(
.:
"docs"
))
parseJSON
=
withObject
"Response"
$
\
o
->
Response
<$>
((
o
.:
"response"
)
>>=
(
.:
"numFound"
))
<*>
((
o
.:
"response"
)
>>=
(
.:
"start"
))
<*>
((
o
.:
"response"
)
>>=
(
.:
"docs"
))
halAPI
::
Proxy
(
HALAPI
doc
)
halAPI
=
Proxy
...
...
src/HAL/Doc.hs
View file @
af3ee73e
module
HAL.Doc
where
module
HAL.Doc
(
module
HAL
.
Doc
.
EntityTree
,
module
HAL
.
Doc
.
Corpus
)
where
import
HAL.Doc.EntityTree
import
HAL.Doc.Corpus
src/HAL/Doc/Corpus.hs
View file @
af3ee73e
...
...
@@ -2,14 +2,11 @@
module
HAL.Doc.Corpus
where
import
GHC.Generics
import
Control.Lens
qualified
as
L
import
Data.Aeson
import
Data.Default
import
Data.Text
(
pack
,
Text
)
import
Control.Applicative
((
<|>
))
import
qualified
Control.Lens
as
L
import
GHC.Generics
import
Protolude
import
Servant.API
(
ToHttpApiData
(
..
))
data
Corpus
=
Corpus
...
...
@@ -29,15 +26,16 @@ instance Default Corpus where
def
=
Corpus
""
def
def
def
def
def
def
def
instance
FromJSON
Corpus
where
parseJSON
(
Object
o
)
=
Corpus
<$>
(
o
.:
"docid"
)
<*>
(
o
.:
"title_s"
<|>
return
[]
)
<*>
(
o
.:
"abstract_s"
<|>
return
[]
)
<*>
(
o
.:?
"submittedDate_s"
)
<*>
(
o
.:?
"source_s"
)
<*>
(
o
.:
"authFullName_s"
<|>
return
[]
)
<*>
(
o
.:
"authOrganism_s"
<|>
return
[]
)
<*>
(
o
.:
"structId_i"
<|>
return
[]
)
parseJSON
=
withObject
"Corpus"
$
\
o
->
Corpus
<$>
(
o
.:
"docid"
)
<*>
(
o
.:
"title_s"
<|>
return
[]
)
<*>
(
o
.:
"en_abstract_s"
<|>
return
[]
)
<*>
(
o
.:?
"submittedDate_s"
)
<*>
(
o
.:?
"source_s"
)
<*>
(
o
.:
"authFullName_s"
<|>
return
[]
)
<*>
(
o
.:
"authOrganism_s"
<|>
return
[]
)
<*>
(
o
.:
"structId_i"
<|>
return
[]
)
instance
ToHttpApiData
Corpus
where
toUrlPiece
_
=
"docid,title_s,abstract_s,submittedDate_s,source_s,authFullName_s,authOrganism_s,structId_i"
toUrlPiece
_
=
"docid,title_s,
en_abstract_s,fr_
abstract_s,submittedDate_s,source_s,authFullName_s,authOrganism_s,structId_i"
src/HAL/Doc/EntityTree.hs
View file @
af3ee73e
module
HAL.Doc.EntityTree
where
import
GHC.Generics
import
Data.Aeson
((
.:
),
(
.:?
),
(
.!=
),
Value
(
..
),
ToJSON
,
FromJSON
(
..
),
encode
)
import
Data.Aeson
((
.:
),
(
.:?
),
(
.!=
),
FromJSON
(
..
),
withObject
)
import
Data.Default
import
Data.Text
(
pack
,
Text
)
import
GHC.Generics
import
Protolude
hiding
(
show
)
import
Protolude.Base
(
Show
(
..
))
import
Servant.API
(
ToHttpApiData
(
..
))
...
...
@@ -20,15 +19,13 @@ instance Default EntityTree where
def
=
EntityTree
""
def
def
instance
FromJSON
EntityTree
where
parseJSON
(
Object
o
)
=
EntityTree
<$>
(
o
.:
"docid"
)
<*>
(
o
.:?
"label_s"
)
<*>
(
o
.:?
"parentEntityTreeid_i"
.!=
[]
)
parseJSON
=
withObject
"EntityTree"
$
\
o
->
EntityTree
<$>
(
o
.:
"docid"
)
<*>
(
o
.:?
"label_s"
)
<*>
(
o
.:?
"parentEntityTreeid_i"
.!=
[]
)
instance
ToHttpApiData
EntityTree
where
toUrlPiece
_
=
"docid,label_s,parentEntityTreeid_i"
instance
Show
EntityTree
where
show
(
EntityTree
id
label
_
)
=
show
label
<>
"("
<>
show
id
<>
")"
show
(
EntityTree
{
..
})
=
show
_label_s
<>
"("
<>
show
_docid
<>
")"
src/HAL/Doc/Struct.hs
View file @
af3ee73e
...
...
@@ -2,15 +2,12 @@
module
HAL.Doc.Struct
where
import
GHC.Generics
import
Data.Aeson
import
Data.Default
import
Data.Text
(
pack
,
Text
)
import
Control.Applicative
((
<|>
))
import
qualified
Control.Lens
as
L
import
GHC.Generics
import
Protolude
import
Servant.API
(
ToHttpApiData
(
..
))
import
qualified
Control.Lens
as
L
data
Struct
=
Struct
{
...
...
@@ -24,10 +21,10 @@ instance Default Struct where
def
=
Struct
def
""
def
instance
FromJSON
Struct
where
parseJSON
(
Object
o
)
=
Struct
<$>
(
o
.:
"docid"
)
<*>
(
o
.:
"label_s"
)
<*>
(
o
.:
"parentDocid_i"
<|>
return
[]
)
parseJSON
=
withObject
"Struct"
$
\
o
->
Struct
<$>
(
o
.:
"docid"
)
<*>
(
o
.:
"label_s"
)
<*>
(
o
.:
"parentDocid_i"
<|>
return
[]
)
instance
ToHttpApiData
Struct
where
toUrlPiece
_
=
"docid,label_s,parentDocid_i"
src/Tree.hs
View file @
af3ee73e
module
Tree
where
import
Network.HTTP.Client
(
newManager
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Servant.Client
hiding
(
Response
)
import
Control.Lens.Getter
((
^.
))
import
Data.Map
((
!?
),
(
!
),
insert
,
empty
,
Map
,
fromList
,
toList
)
import
qualified
Data.Map
as
M
import
Data.Map.Internal
(
merge
,
preserveMissing
,
zipWithMatched
)
import
Data.Aeson
import
Data.List
(
groupBy
,
isInfixOf
)
import
Data.List.Split
(
chunksOf
)
import
Data.Either
(
rights
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Scientific
(
Scientific
,
floatingOrInteger
)
import
qualified
Data.Vector
as
V
import
Text.Printf
import
Data.Map
qualified
as
Map
import
Data.Map
(
insert
)
import
Data.Map.Internal
(
merge
,
preserveMissing
,
zipWithMatched
)
import
Data.Text
qualified
as
T
import
Data.Text.Format
(
format
)
import
Data.Text.Lazy
qualified
as
TL
import
GHC.Generics
import
HAL.Client
import
HAL
import
HAL.Client
import
HAL.Doc.Struct
import
Data.Text
(
Text
,
pack
)
import
Protolude
--import Text.Printf
formatParentIdRequest
::
[
Struct
]
->
Maybe
Text
formatParentIdRequest
[]
=
Nothing
formatParentIdRequest
(
x
:
[]
)
=
Just
.
pack
.
show
$
_struct_docid
x
formatParentIdRequest
(
x
:
[]
)
=
Just
.
T
.
pack
.
show
$
_struct_docid
x
formatParentIdRequest
(
x
:
xs
)
=
(
Just
.
pack
.
show
$
_struct_docid
x
)
(
Just
.
T
.
pack
.
show
$
_struct_docid
x
)
<>
(
Just
" || "
)
<>
formatParentIdRequest
xs
...
...
@@ -43,35 +36,42 @@ fetchChildren [] = pure []
fetchChildren
ds
=
(
ds
<>
)
<$>
(
fetchChildren
=<<
ds2Child
ds
)
isChildOf
::
Struct
->
Struct
->
Bool
isChildOf
(
Struct
i
l
p
)
(
Struct
i'
l'
p'
)
=
not
.
null
$
filter
(
\
id
->
id
==
(
pack
$
show
i
))
p'
isChildOf
(
Struct
i
_
_
)
(
Struct
_
_
p'
)
=
not
.
null
$
filter
(
\
id
->
id
==
(
T
.
pack
$
show
i
))
p'
data
DocTree
=
DocTree
Struct
Int
[
DocTree
]
deriving
(
Show
,
Generic
)
buildTree
::
Int
->
[
Struct
]
->
Struct
->
DocTree
buildTree
depth
docs
id
=
DocTree
id
depth
(
buildTree
(
depth
+
1
)
docs
<$>
children
)
where
children
=
filter
(
isChildOf
id
)
docs
buildTree
depth
docs'
id
=
DocTree
id
depth
(
buildTree
(
depth
+
1
)
docs'
<$>
children
)
where
children
=
filter
(
isChildOf
id
)
docs'
formatTree
::
DocTree
->
String
formatTree
tree
@
(
DocTree
doc
depth
children
)
=
printf
"%s%s
\n
%s"
(
addSpace
)
(
show
doc
)
(
concat
$
formatTree
<$>
children
)
where
addSpace
|
depth
>
0
=
"├"
<>
(
replicate
(
depth
*
depth
+
depth
)
'─'
)
formatTree
::
DocTree
->
Text
formatTree
(
DocTree
doc
depth
children
)
=
TL
.
toStrict
$
format
"{}{}
\n
{}"
[
addSpace
,
show
doc
,
T
.
concat
$
formatTree
<$>
children
]
where
addSpace
::
Text
addSpace
|
depth
>
0
=
"├"
<>
(
T
.
replicate
(
depth
*
depth
+
depth
)
"─"
)
|
otherwise
=
"🌲"
findDeepest
::
Map
Int
Int
->
DocTree
->
Map
Int
Int
findDeepest
m
tree
@
(
DocTree
doc
@
(
Struct
docid
_
_
)
depth
children
)
=
findDeepest
m
(
DocTree
(
Struct
docid
_
_
)
depth
children
)
=
mergeMap
map1
maps
where
map1
=
insert
docid
depth
m
maps
=
foldl
mergeMap
empty
$
findDeepest
m
<$>
children
maps
=
foldl
mergeMap
Map
.
empty
$
findDeepest
m
<$>
children
mergeMap
m1
m2
=
merge
preserveMissing
preserveMissing
(
zipWithMatched
whenMatch
)
m1
m2
whenMatch
k
v
v'
=
if
v
>
v'
then
v
else
v'
whenMatch
_
k
v
v'
=
if
v
>
v'
then
v
else
v'
isDeep
::
Map
Int
Int
->
DocTree
->
Bool
isDeep
m
(
DocTree
(
Struct
id
_
_
)
depth
_
)
=
depth
>=
(
fromMaybe
0
$
M
.
lookup
id
m
)
isDeep
m
(
DocTree
(
Struct
id
_
_
)
depth
_
)
=
depth
>=
(
fromMaybe
0
$
M
ap
.
lookup
id
m
)
removeDuplicate
::
Map
Int
Int
->
DocTree
->
DocTree
removeDuplicate
deepMap
tree
@
(
DocTree
doc
depth
children
)
=
DocTree
doc
depth
(
removeDuplicate
deepMap
<$>
filter
(
isDeep
deepMap
)
children
)
removeDuplicate
deepMap
(
DocTree
doc
depth
children
)
=
DocTree
doc
depth
(
removeDuplicate
deepMap
<$>
filter
(
isDeep
deepMap
)
children
)
noDuplicateTree
::
DocTree
->
DocTree
noDuplicateTree
tree
=
removeDuplicate
(
findDeepest
M
.
empty
tree
)
tree
noDuplicateTree
tree
=
removeDuplicate
(
findDeepest
M
ap
.
empty
tree
)
tree
stack.yaml
deleted
100644 → 0
View file @
7b740eee
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver
:
url
:
https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# subdirs:
# - auto-update
# - wai
packages
:
-
.
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.9"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
Write
Preview