Types.hs
1 {-| 2 Module : Gargantext.Types 3 Description : 4 Copyright : (c) CNRS, 2017-Present 5 License : AGPL + CECILL v3 6 Maintainer : team@gargantext.org 7 Stability : experimental 8 Portability : POSIX 9 10 Here is a longer description of this module, containing some 11 commentary with @some markup@. 12 -} 13 14 {-# OPTIONS_GHC -fno-warn-deprecations #-} 15 16 ------------------------------------------------------------------------ 17 {-# LANGUAGE TemplateHaskell #-} 18 {-# LANGUAGE DerivingStrategies #-} 19 20 module Gargantext.Core.Types ( module Gargantext.Core.Types.Main 21 , module Gargantext.Database.Admin.Types.Node 22 , DebugMode(..), withDebugMode 23 , Term(..), Terms(..), TermsCount, TermsWithCount 24 , TokenTag(..), POS(..), NER(..) 25 , Label, Stems 26 , HasValidationError(..), assertValid 27 , Name 28 , TableResult(..), NodeTableResult 29 , Ordering(..) 30 , Typed(..), withType , unTyped 31 , TODO(..) 32 ) where 33 34 import Control.Lens (Prism', (#), over) 35 import Data.Aeson ( withText ) 36 import Data.Set (empty) 37 import Data.Swagger (ToParamSchema, ToSchema(..)) 38 import Data.Text (unpack) 39 import Data.Validity ( validationIsValid, Validation ) 40 import Gargantext.Core.Types.Main 41 import Gargantext.Core.Utils.Prefix (unPrefix, wellNamedSchema) 42 import Gargantext.Database.Admin.Types.Node 43 import Gargantext.Prelude hiding (Ordering, empty) 44 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) 45 46 ------------------------------------------------------------------------ 47 48 data DebugMode = DebugMode { activated :: Bool } 49 50 withDebugMode :: (Show a) => DebugMode -> Text -> a -> b -> b 51 withDebugMode (DebugMode True ) msg var a = trace ("DEBUG" <> msg <> (show var) :: Text) a 52 withDebugMode (DebugMode False) _ _ a = a 53 54 ------------------------------------------------------------------------ 55 data Ordering = Down | Up 56 deriving (Enum, Show, Eq, Bounded) 57 58 ------------------------------------------------------------------------ 59 type Name = Text 60 61 newtype Term = Term { getTerm :: Text } 62 deriving newtype (Eq, Ord, IsString, Show) 63 64 type Stems = Set Text 65 type Label = [Text] 66 67 data Terms = Terms { _terms_label :: Label 68 , _terms_stem :: Stems 69 } deriving (Ord, Show) 70 instance Eq Terms where 71 (==) (Terms { _terms_stem = s1 }) (Terms { _terms_stem = s2 }) = s1 == s2 72 73 type TermsCount = Int 74 75 type TermsWithCount = (Terms, TermsCount) 76 77 ------------------------------------------------------------------------ 78 data Tag = POS | NER 79 deriving (Show, Eq) 80 ------------------------------------------------------------------------ 81 data POS = NP 82 | JJ | VB 83 | CC | IN | DT 84 | ADV 85 | NotFound { not_found :: [Char] } 86 deriving (Show, Generic, Eq, Ord) 87 ------------------------------------------------------------------------ 88 -- https://pythonprogramming.net/part-of-speech-tagging-nltk-tutorial/ 89 instance FromJSON POS where 90 parseJSON = withText "String" (\x -> pure (pos $ unpack x)) 91 where 92 pos :: [Char] -> POS 93 pos "ADJ" = JJ 94 pos "CC" = CC 95 pos "CCONJ"= CC 96 pos "DT" = DT 97 pos "DET" = DT 98 pos "IN" = IN 99 pos "JJ" = JJ 100 pos "PROPN" = JJ 101 pos "JJR" = JJ 102 pos "JJS" = JJ 103 pos "NC" = NP 104 pos "NN" = NP 105 pos "NOUN" = NP 106 pos "NNS" = NP 107 pos "NNP" = NP 108 pos "NNPS" = NP 109 pos "NP" = NP 110 pos "VB" = VB 111 pos "VERB" = VB 112 pos "VBD" = VB 113 pos "VBG" = VB 114 pos "VBN" = VB 115 pos "VBP" = VB 116 pos "VBZ" = VB 117 pos "RB" = ADV 118 pos "ADV" = ADV 119 pos "RBR" = ADV 120 pos "RBS" = ADV 121 pos "WRB" = ADV 122 -- French specific 123 pos "P" = IN 124 pos "PUNCT" = IN 125 pos x = NotFound x 126 127 instance ToJSON POS 128 instance Hashable POS 129 ------------------------------------------------------------------------ 130 data NER = PERSON | ORGANIZATION | LOCATION | NoNER { noNer :: !Text } 131 deriving (Show, Generic) 132 ------------------------------------------------------------------------ 133 instance FromJSON NER where 134 parseJSON = withText "String" (\x -> pure (ner $ unpack x)) 135 where 136 ner :: [Char] -> NER 137 ner "PERSON" = PERSON 138 ner "PER" = PERSON 139 ner "ORGANIZATION" = ORGANIZATION 140 ner "LOCATION" = LOCATION 141 ner "LOC" = LOCATION 142 ner x = NoNER (cs x) 143 144 instance ToJSON NER 145 146 data TokenTag = TokenTag { _my_token_word :: [Text] 147 , _my_token_lemma :: Set Text 148 , _my_token_pos :: Maybe POS 149 , _my_token_ner :: Maybe NER 150 } deriving (Show) 151 152 instance Semigroup TokenTag where 153 (<>) (TokenTag w1 s1 p1 n1) (TokenTag w2 s2 p2 _) = TokenTag (w1 <> w2) (s1 <> s2) p3 n1 154 where 155 p3 = case (p1,p2) of 156 (Just JJ, Just NP) -> Just NP 157 (Just VB, Just NP) -> Just NP 158 _ -> p1 159 160 161 instance Monoid TokenTag where 162 mempty = TokenTag [] empty Nothing Nothing 163 mconcat = foldl' mappend mempty 164 -- mappend t1 t2 = (<>) t1 t2 165 166 167 class HasValidationError e where 168 _ValidationError :: Prism' e Validation 169 170 assertValid :: (MonadError e m, HasValidationError e) => Validation -> m () 171 assertValid v = when (not $ validationIsValid v) $ throwError $ _ValidationError # v 172 -- assertValid :: MonadBase IO m => Validation -> m () 173 -- assertValid v = when (not $ validationIsValid v) $ fail $ show v 174 175 -- | NodeTableResult (Table computations) 176 type NodeTableResult a = TableResult (Node a) 177 178 179 data TableResult a = TableResult { tr_count :: Int 180 , tr_docs :: [a] 181 } deriving (Generic, Show) 182 183 $(deriveJSON (unPrefix "tr_") ''TableResult) 184 185 instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where 186 declareNamedSchema = wellNamedSchema "tr_" 187 188 instance Arbitrary a => Arbitrary (TableResult a) where 189 arbitrary = TableResult <$> arbitrary <*> arbitrary 190 191 ---------------------------------------------------------------------------- 192 data Typed a b = 193 Typed { _withType :: a 194 , _unTyped :: b 195 } 196 deriving (Generic, Show, Eq, Ord) 197 198 makeLenses ''Typed 199 200 instance Functor (Typed a) where 201 fmap = over unTyped 202 203 ---------------------------------------------------------------------------- 204 -- TO BE removed 205 data TODO = TODO 206 deriving (Generic) 207 208 instance ToSchema TODO where 209 instance ToParamSchema TODO where 210 ----------------------------------------------------------------------------