Verified Commit 60577438 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch 'dev' into 551-dev-annotation-fix

parents a1538c90 cff56727
{
"name": "Gargantext",
"version": "0.0.6.9.9.5.2",
"version": "0.0.6.9.9.5.4",
"scripts": {
"generate-purs-packages-nix": "./nix/generate-purs-packages.nix",
"generate-psc-packages-nix": "./nix/generate-packages-json.bash",
......
......@@ -18,7 +18,6 @@ import Data.FoldableWithIndex (foldlWithIndex, foldrWithIndex)
import Data.List (List(..), (:))
import Data.Map (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String.Common (joinWith)
import Data.Tuple (Tuple(..), snd)
import Data.Tuple.Nested ((/\))
......@@ -26,7 +25,7 @@ import DOM.Simple.Event as DE
import Effect (Effect)
import Gargantext.Components.Annotation.Menu (annotationMenu, AnnotationMenu)
import Gargantext.Components.Annotation.Types (MenuType(..), ModeType(..), termClass)
import Gargantext.Core.NgramsTable.Functions (findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Core.NgramsTable.Functions (Cache, findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Core.NgramsTable.Types (HighlightElement, NgramsRepoElement(..), NgramsTable(..), NgramsTerm(..), parentMap)
import Gargantext.Types (CTabNgramType(..), TermList)
import Gargantext.Utils.Reactix as R2
......@@ -46,6 +45,7 @@ type Props =
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
, text :: Maybe String
, mode :: ModeType
, cache :: Record Cache
)
type MouseEvent = E.SyntheticEvent DE.MouseEvent
......@@ -81,6 +81,7 @@ annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
, setTermList
, text: fieldText
, mode
, cache
} _ = do
-- | States
-- |
......@@ -91,7 +92,7 @@ annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
-- | Computed
-- |
let
wrap :: HighlightElement -> Record RunProps
wrap :: Tuple String (List (Tuple NgramsTerm TermList)) -> Record RunProps
wrap (text /\ list)
= { list
, onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
......@@ -113,7 +114,7 @@ annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
H.div
{ className: "annotated-field-runs" }
((\p -> annotateRun p) <$> wrap <$> compileCached ngrams fieldText)
((\p -> annotateRun p) <$> wrap <$> compile cache ngrams fieldText)
AdditionMode ->
......@@ -134,24 +135,12 @@ annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
-----------------------------------------------------------
compileCached :: NgramsTable
-> Maybe String
-> Array HighlightElement
compileCached ngrams = compile ngrams { pm, pats }
where
NgramsTable { ngrams_repo_elements } = ngrams
pm = parentMap ngrams_repo_elements
pats :: Array NgramsTerm
pats = A.fromFoldable $
foldrWithIndex (\term (NgramsRepoElement nre) acc -> Set.union acc $ Set.insert term nre.children) Set.empty ngrams_repo_elements
compile ::
NgramsTable
-> { pm :: Map NgramsTerm NgramsTerm, pats :: Array NgramsTerm }
Record Cache
-> NgramsTable
-> Maybe String
-> Array HighlightElement
compile ngrams cache = maybe [] (highlightNgrams CTabTerms ngrams cache)
compile cache ngrams = maybe [] (highlightNgrams CTabTerms ngrams cache)
-- Runs
......
......@@ -37,7 +37,7 @@ type AnnotationMenu =
annotationMenu :: R2.Leaf Props
annotationMenu = R2.leaf annotationMenuCpt
annotationMenuCpt :: R.Component Props
annotationMenuCpt = here.component "annotationMenu" cpt where
annotationMenuCpt = here.component "main" cpt where
cpt { menuRef } _ = do
-- Render
pure $
......
......@@ -19,7 +19,7 @@ import Gargantext.Components.Category (ratingSimpleLoader)
import Gargantext.Components.Document.Types (DocPath, Document(..), LoadedData, initialState)
import Gargantext.Components.NgramsTable.AutoSync (useAutoSync)
import Gargantext.Components.Node (NodePoly(..))
import Gargantext.Core.NgramsTable.Functions (addNewNgramA, applyNgramsPatches, coreDispatch, findNgramRoot, setTermListA)
import Gargantext.Core.NgramsTable.Functions (addNewNgramA, applyNgramsPatches, coreDispatch, findNgramRoot, setTermListA, computeCache)
import Gargantext.Core.NgramsTable.Types (CoreAction(..), Versioned(..), replace)
import Gargantext.Hooks.FirstEffect (useFirstEffect')
import Gargantext.Utils ((?))
......@@ -88,11 +88,14 @@ layoutCpt = here.component "layout" cpt where
ngrams = applyNgramsPatches state' initTable
cache = computeCache ngrams
annotate text = AnnotatedField.annotatedField
{ ngrams
, setTermList
, text
, mode: mode'
, cache
}
setTermListOrAddA ngram Nothing =
......
......@@ -11,6 +11,7 @@ import Data.List as L
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as Set
import Data.Traversable (traverse_)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
......@@ -19,7 +20,7 @@ import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (Variant(..))
import Gargantext.Components.Table as Tbl
import Gargantext.Core.NgramsTable.Functions (applyNgramsPatches, setTermListA, tablePatchHasNgrams)
import Gargantext.Core.NgramsTable.Types (Action(..), NgramsClick, NgramsDepth, NgramsElement, NgramsTable, NgramsTablePatch, NgramsTerm, _NgramsElement, _NgramsRepoElement, _children, _list, _ngrams, _occurrences, ngramsTermText, replace)
import Gargantext.Core.NgramsTable.Types (Action(..), CoreAction, NgramsClick, NgramsDepth, NgramsElement, NgramsTable, NgramsTablePatch, NgramsTerm, _NgramsElement, _NgramsRepoElement, _children, _list, _ngrams, _occurrences, ngramsTermText, replace)
import Gargantext.Hooks.FirstEffect (useFirstEffect')
import Gargantext.Types as GT
import Gargantext.Utils ((?))
......@@ -297,18 +298,23 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt
Nothing ->
span ngramsStyle
termList :: GT.TermList
termList = ngramsElement ^. _NgramsElement <<< _list
ngramsStyle :: Array DOM.Props
ngramsStyle = [termStyle termList ngramsOpacity]
ngramsEdit { ngrams: n } = Just $ dispatch $ SetParentResetChildren (Just n) (ngramsChildren n)
tbl :: NgramsTable
tbl = applyNgramsPatches { ngramsLocalPatch
, ngramsStagePatch: mempty
, ngramsValidPatch: mempty
, ngramsVersion: 0 } ngramsTable
getNgramsChildren' :: NgramsTerm -> Array NgramsTerm
getNgramsChildren' n = A.fromFoldable $ ngramsChildren n
ngramsChildren :: NgramsTerm -> List NgramsTerm
ngramsChildren n = tbl ^.. ix n <<< _NgramsRepoElement <<< _children <<< folded
ngramsClick =
Just <<< dispatch <<< CoreAction <<< cycleTermListItem <<< view _ngrams
ngramsClick :: { depth :: Int, ngrams :: NgramsTerm } -> Maybe (Effect Unit)
ngramsClick p = Just $ do
traverse_ (dispatch <<< CoreAction <<< cycleTermListItem) (A.cons p.ngrams $ getNgramsChildren' p.ngrams)
-- ^ This is the old behavior it is nicer to use since one can
-- rapidly change the ngram list without waiting for confirmation.
-- However this might expose bugs. One of them can be reproduced
......@@ -361,6 +367,7 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt
| ngramsTransient = 0.5
| otherwise = 1.0
cycleTermListItem :: NgramsTerm -> CoreAction
cycleTermListItem n = setTermListA n (replace termList (nextTermList termList))
......
module Gargantext.Components.Nodes.Home
( Action(..)
( HomeAction(..)
, HomeProps
, State(..)
, Tuto(..)
......@@ -18,7 +18,7 @@ module Gargantext.Components.Nodes.Home
, jumboTitle
, langLandingData
, license
, performAction
, performHomeAction
, playTutos
, startTutos
, summary
......@@ -36,13 +36,14 @@ import Data.Newtype (class Newtype)
import Effect (Effect)
import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..), Elevation(..), ModalSizing(..), Position(..), TooltipPosition(..), Variant(..))
import Gargantext.Components.Data.Landing (BlockText(..), BlockTexts(..), Button(..), LandingData(..))
import Gargantext.Components.FolderView as FV
import Gargantext.Components.Lang (LandingLang(..))
import Gargantext.Components.Lang.Landing.EnUS as En
import Gargantext.Components.Lang.Landing.FrFR as Fr
import Gargantext.Config as Config
import Gargantext.Sessions (Sessions)
import Gargantext.Sessions (Session(..), Sessions, Action(Logout), unSessions)
import Gargantext.Sessions as Sessions
import Gargantext.Sessions.Types (Session(..), cleanBackendUrl)
import Gargantext.Utils.Reactix as R2
......@@ -51,6 +52,9 @@ import Reactix.DOM.HTML as H
import Routing.Hash (setHash)
import Toestand as T
import Effect.Console (log)
here :: R2.Here
here = R2.here "Gargantext.Components.Nodes.Home"
......@@ -61,17 +65,17 @@ derive instance Newtype State _
initialState :: State
initialState = State { userName: "", password: "" }
data Action
data HomeAction
= Documentation
| Enter
| Login
| SignUp
performAction :: Action -> Effect Unit
performAction Documentation = pure unit
performAction Enter = void $ setHash "/search"
performAction Login = void $ setHash "/login"
performAction SignUp = pure unit
performHomeAction :: HomeAction -> Effect Unit
performHomeAction Documentation = pure unit
performHomeAction Enter = void $ setHash "/search"
performHomeAction Login = void $ setHash "/login"
performHomeAction SignUp = pure unit
langLandingData :: LandingLang -> LandingData
langLandingData LL_FR = Fr.landingData
......@@ -226,7 +230,7 @@ tutorial :: R2.Leaf TutorialProps
tutorial = R2.leaf tutorialCpt
tutorialCpt :: R.Component TutorialProps
tutorialCpt = here.component "tutorial" cpt where
cpt { sessions } _ = do
cpt { boxes, sessions } _ = do
pure $
......@@ -249,6 +253,9 @@ tutorialCpt = here.component "tutorial" cpt where
[ video x.id, H.h4 {} [ H.text x.title ], H.p {} [ H.text x.text ] ]
-}
onSignOutClick session = void $ Sessions.change (Logout session) boxes.sessions
makeFolders :: Array Session -> Array R.Element
makeFolders s = sessionToFolder <$> s
where
......@@ -266,14 +273,33 @@ tutorialCpt = here.component "tutorial" cpt where
B.wad
[ "d-flex", "align-items-center" ]
[
B.icon
{ name: "user" }
,
B.wad_
[ "virtual-space", "w-1" ]
B.wad
[ "text-left", "w-10/12" ]
[
B.icon
{ name: "user", className: "pr-1" }
,
B.span_ $
username <> "@" <> cleanBackendUrl backend
]
,
B.span_ $
username <> "@" <> cleanBackendUrl backend
B.wad
[ "text-right", "w-2/12" ]
[
B.tooltipContainer
{ position: TooltipPosition Top
, delayShow: 600
, tooltipSlot:
B.span_ "Log out"
, defaultSlot:
B.iconButton
{ name: "sign-out"
, callback: \_ -> onSignOutClick session
, elevation: Level2
, className: "text-light"
}
}
]
]
]
,
......@@ -286,6 +312,7 @@ tutorialCpt = here.component "tutorial" cpt where
}
]
]
startTutos :: Array Tuto
startTutos =
......
......@@ -114,7 +114,7 @@ lookupRootList ngram (NgramsTable {ngrams_repo_elements: elts}) =
Nothing -> Nothing
Just (NgramsRepoElement {list}) -> Just list -- assert root == Nothing
lookupRootListWithChildren :: NgramsTerm -> NgramsTable -> Cache -> Maybe TermList
lookupRootListWithChildren :: NgramsTerm -> NgramsTable -> Record Cache -> Maybe TermList
lookupRootListWithChildren ngram table@(NgramsTable {ngrams_repo_elements: elts}) { pm, pats } =
case Map.lookup ngram elts of
Nothing -> -- try to find in children
......@@ -140,12 +140,23 @@ wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <
Left e -> unsafePartial $ crashWith e
Right r -> r
type Cache = { pm :: Map NgramsTerm NgramsTerm
, pats :: Array NgramsTerm }
type Cache =
( pm :: Map NgramsTerm NgramsTerm
, pats :: Array NgramsTerm )
computeCache :: NgramsTable -> Record Cache
computeCache ngrams = { pm, pats }
where
NgramsTable { ngrams_repo_elements } = ngrams
pm = parentMap ngrams_repo_elements
pats :: Array NgramsTerm
pats = A.fromFoldable $
foldrWithIndex (\term (NgramsRepoElement nre) acc -> Set.union acc $ Set.insert term nre.children) Set.empty ngrams_repo_elements
-- TODO: while this function works well with word boundaries,
-- it inserts too many spaces.
highlightNgrams :: CTabNgramType -> NgramsTable -> Cache -> String -> Array HighlightElement
highlightNgrams :: CTabNgramType -> NgramsTable -> Record Cache -> String -> Array HighlightElement
highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) { pm, pats } input0 =
-- trace {pats, input0, input, ixs} \_ ->
A.fromFoldable ((\(s /\ ls)-> undb s /\ ls) <$> unsafePartial (foldl goFold ((input /\ Nil) : Nil) ixs))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment