Use bimaps for HasDbid

This allows us to have only one single (static) map which will be
treated by GHC as a CAF.

gargantext.cabal

@@ -413,6 +413,7 @@ library
     , base >=4.7 && <5
     , base16-bytestring ^>= 1.0.2.0
     , base64-bytestring ^>= 1.1.0.0
+    , bimap >= 0.5.0
     , blaze-html ^>= 0.9.1.2
     , blaze-markup ^>= 0.8.2.8
     , blaze-svg ^>= 0.3.6.1

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -19,11 +19,12 @@ import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.GraphQL.PolicyCheck
 import Gargantext.API.GraphQL.Types
+import Gargantext.Core (fromDBid)
 import Gargantext.Core.Types (Tree, NodeTree, NodeType)
 import Gargantext.Core.Types.Main ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
-import Gargantext.Database.Admin.Config (fromNodeTypeId)
-import Gargantext.Database.Admin.Types.Node qualified as NN
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (UnsafeMkNodeId))
+import Gargantext.Database.Admin.Types.Node qualified as NN
 import Gargantext.Database.Prelude (CmdCommon)
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Tree qualified as T
@@ -104,11 +105,11 @@ resolveParent Nothing = pure Nothing
 
 
 nodeToTreeNode :: NN.Node json -> Maybe TreeNode
-nodeToTreeNode N.Node {..} = if (fromNodeTypeId _node_typename /= NN.NodeFolderShared) && (fromNodeTypeId _node_typename /= NN.NodeTeam)
+nodeToTreeNode N.Node {..} = if (fromDBid _node_typename /= NN.NodeFolderShared) && (fromDBid _node_typename /= NN.NodeTeam)
                              then
                              Just TreeNode { id        = NN.unNodeId _node_id
                                            , name      = _node_name
-                                           , node_type = fromNodeTypeId _node_typename
+                                           , node_type = fromDBid _node_typename
                                            , parent_id = NN.unNodeId <$> _node_parent_id
                                            }
                              else
@@ -121,7 +122,7 @@ convertDbTreeToTreeNode :: T.DbTreeNode -> TreeNode
 convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_parentId } = TreeNode
   { name = _dt_name
   , id = NN.unNodeId _dt_nodeId
-  , node_type = fromNodeTypeId _dt_typeId
+  , node_type = fromDBid _dt_typeId
   , parent_id = NN.unNodeId <$> _dt_parentId
   }
 

src/Gargantext/Core.hs

@@ -10,13 +10,15 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Gargantext.Core
   where
 
 import Data.Aeson
 import Data.LanguageCodes qualified as ISO639
-import Data.Map qualified as Map
+import Data.Bimap qualified as Bimap
+import Data.Bimap (Bimap)
 import Data.Morpheus.Types (GQLType)
 import Data.Swagger
 import Data.Text (pack)
@@ -132,15 +134,15 @@ allLangs = [minBound .. maxBound]
 
 class HasDBid a where
   toDBid     :: a   -> Int
-  fromDBid :: Int -> a
+  lookupDBid :: Int -> Maybe a
 
 -- NOTE: We try to use numeric codes for countries
 -- https://en.wikipedia.org/wiki/List_of_ISO_3166_country_codes
 -- https://en.wikipedia.org/wiki/ISO_3166-1_numeric#004
 -- The pattern matching ensures this mapping will always be total
 -- once we add a new 'Lang'.
-lang2id :: Map Lang Int
-lang2id = Map.fromList $ allLangs <&> \lid -> case lid of
+langIds :: Bimap Lang Int
+langIds = Bimap.fromList $ allLangs <&> \lid -> case lid of
   All -> (lid, 0)
   DE  -> (lid, 276)
   EL  -> (lid, 300)
@@ -154,19 +156,11 @@ lang2id = Map.fromList $ allLangs <&> \lid -> case lid of
   UK  -> (lid, 804)
   ZH  -> (lid, 156)
 
--- | /static/ conversion map between an 'Int' and a 'Lang'. Automatically kept up-to-date
--- as it's derived from 'lang2id'.
-id2lang :: Map Int Lang
-id2lang = Map.fromList . map swap . Map.toList $ lang2id
-
 instance HasDBid Lang where
   -- /NOTE/ this lookup cannot fail because 'dbIds' is defined as a total function
   -- over its domain.
-  toDBid lang = lang2id Map.! lang
-
-  fromDBid dbId = case Map.lookup dbId id2lang of
-                    Just la -> la
-                    Nothing -> panic "HasDBid lang, not implemented"
+  toDBid lang     = langIds Bimap.! lang
+  lookupDBid dbId = Bimap.lookupR dbId langIds
 
 ------------------------------------------------------------------------
 data NLPServerConfig = NLPServerConfig
@@ -186,7 +180,13 @@ instance HasDBid PosTagAlgo where
   toDBid CoreNLP        = 1
   toDBid JohnSnowServer = 2
   toDBid Spacy          = 3
-  fromDBid 1 = CoreNLP
-  fromDBid 2 = JohnSnowServer
-  fromDBid 3 = Spacy
-  fromDBid _ = panic "HasDBid posTagAlgo : Not implemented"
+  lookupDBid 1          = Just CoreNLP
+  lookupDBid 2          = Just JohnSnowServer
+  lookupDBid 3          = Just Spacy
+  lookupDBid _          = Nothing
+
+
+fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
+fromDBid i = case lookupDBid i of
+  Nothing -> panic $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
+  Just v  -> v

src/Gargantext/Core/NodeStory.hs

@@ -115,7 +115,7 @@ import GHC.Conc (TVar, newTVar, readTVar, writeTVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Admin.Config (nodeTypeId)
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Prelude (DbCmd', HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
@@ -123,6 +123,7 @@ import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude hiding (to)
 import Gargantext.Prelude.Database
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
+import Gargantext.Core (toDBid)
 
 ------------------------------------------------------------------------
 data NodeStoryEnv = NodeStoryEnv
@@ -303,7 +304,7 @@ nodeExists c nId = (== [PGS.Only True])
 
 getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId]
 getNodesIdWithType c nt = do
-  ns <- runPGSQuery c query (PGS.Only $ nodeTypeId nt)
+  ns <- runPGSQuery c query (PGS.Only $ toDBid nt)
   pure $ map (\(PGS.Only nId) -> UnsafeMkNodeId nId) ns
   where
     query :: PGS.Query

src/Gargantext/Core/Text/List/Social/Find.hs

@@ -14,8 +14,9 @@ module Gargantext.Core.Text.List.Social.Find
 -- findList imports
 import Control.Lens (view)
 
+import Gargantext.Core (toDBid)
 import Gargantext.Core.Types.Individu
-import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (DBCmd)
 import Gargantext.Database.Query.Table.Node.Error
@@ -28,7 +29,7 @@ findListsId :: (HasNodeError err, HasTreeError err)
             => User -> NodeMode -> DBCmd err [NodeId]
 findListsId u mode = do
   rootId <- getRootId u
-  ns <- map (view dt_nodeId) <$> filter ((== nodeTypeId NodeList) . (view dt_typeId))
+  ns <- map (view dt_nodeId) <$> filter ((== toDBid NodeList) . (view dt_typeId))
                              <$> findNodes' rootId mode
   pure ns
 

src/Gargantext/Core/Types/Main.hs

@@ -19,7 +19,7 @@ module Gargantext.Core.Types.Main where
 
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.TH (deriveJSON)
-import Data.Map.Strict (fromList, lookup)
+import Data.Bimap (Bimap)
 import Data.Swagger
 import Data.Text (unpack, pack)
 import Gargantext.Core
@@ -29,6 +29,7 @@ import Gargantext.Prelude
 import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Data.Bimap as Bimap
 
 type CorpusName = Text
 ------------------------------------------------------------------------
@@ -79,21 +80,20 @@ instance ToHttpApiData ListType where
 type ListTypeId = Int
 
 instance HasDBid ListType where
-  toDBid   = listTypeId
-  fromDBid = (fromMaybe (panic "Instance HasDBid fromDBid ListType")) .  fromListTypeId
+  toDBid  lt = listTypeIds Bimap.! lt -- cannot fail, see /NOTE/ below.
+  lookupDBid = fromListTypeId
 
 -- FIXME Candidate: 0 and Stop : 1
-listTypeId :: ListType -> ListTypeId
-listTypeId StopTerm      = 0
-listTypeId CandidateTerm = 1
-listTypeId MapTerm       = 2
+-- | Bidirectional map between a 'ListType' and a 'ListTypeId'.
+-- /NOTE/: The way this is constructed is total in its domain.
+listTypeIds :: Bimap ListType ListTypeId
+listTypeIds = Bimap.fromList $ [minBound .. maxBound] <&> \lt -> case lt of
+  StopTerm      -> (lt, 0)
+  CandidateTerm -> (lt, 1)
+  MapTerm       -> (lt, 2)
 
 fromListTypeId :: ListTypeId -> Maybe ListType
-fromListTypeId i = lookup i
-                 $ fromList
-                 [ (listTypeId l, l)
-                 | l <- [StopTerm, CandidateTerm, MapTerm]
-                 ]
+fromListTypeId = flip Bimap.lookupR listTypeIds
 
 -- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue
 --              | TfidfCorpus | TfidfGlobal   | TirankLocal | TirankGlobal

src/Gargantext/Database/Action/Flow/Utils.hs

@@ -24,6 +24,7 @@ import Gargantext.Database.Query.Table.ContextNodeNgrams
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Types
 import Gargantext.Prelude
+import Gargantext.Core (toDBid)
 
 
 data DocumentIdWithNgrams a b =
@@ -41,7 +42,7 @@ insertDocNgrams lId m = do
   where
     ns = [ ContextNodeNgrams (nodeId2ContextId docId)
                              lId (ng^.index)
-                             (ngramsTypeId t)
+                             (NgramsTypeId $ toDBid t)
                              (fromIntegral i)
                              cnt
          | (ng, t2n2i)       <- HashMap.toList m

src/Gargantext/Database/Action/Metrics/NgramsByContext.hs

@@ -31,7 +31,7 @@ import Gargantext.Core
 import Gargantext.Data.HashMap.Strict.Utils as HM
 import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId (..), MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
 import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
-import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude
 
 -- | fst is size of Supra Corpus
@@ -72,7 +72,7 @@ getContextsByNgramsUser cId nt =
         runPGSQuery queryNgramsByContextUser
                     ( cId'
                     , toDBid NodeDocument
-                    , ngramsTypeId nt'
+                    , toDBid nt'
            --         , 100 :: Int -- limit
            --         , 0   :: Int -- offset
                     )
@@ -118,7 +118,7 @@ getOccByNgramsOnlyFast cId lId nt = do
       run cId' lId' nt' = runPGSQuery query
                 ( cId'
                 , lId'
-                , ngramsTypeId nt'
+                , toDBid nt'
                 )
 
       query :: DPS.Query
@@ -186,7 +186,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
                 , cId
                 , Values fields ((DPS.Only . unNgramsTerm) <$> (List.take 10000 tms))
                 , cId
-                , ngramsTypeId nt
+                , toDBid nt
                 )
     where
       fields = [QualifiedIdentifier Nothing "text"]
@@ -221,7 +221,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt =
                 , toDBid NodeDocument
                 , cId
                 , cId
-                , ngramsTypeId nt
+                , toDBid nt
                 )
 
 queryNgramsOccurrencesOnlyByContextUser_withSample' :: DPS.Query
@@ -285,7 +285,7 @@ selectNgramsOnlyByContextUser cId ls nt tms =
                          (DPS.Only <$> map DPS.toField ls)
                 , cId
                 , toDBid NodeDocument
-                , ngramsTypeId nt
+                , toDBid nt
                 )
     where
       fields = [QualifiedIdentifier Nothing "text"]
@@ -330,7 +330,7 @@ selectNgramsOnlyByDocUser dId ls nt tms =
                 , Values [QualifiedIdentifier Nothing "int4"]
                          (DPS.Only <$> (map DPS.toField ls))
                 , dId
-                , ngramsTypeId nt
+                , toDBid nt
                 )
     where
       fields = [QualifiedIdentifier Nothing "text"]
@@ -370,7 +370,7 @@ selectNgramsByContextMaster :: HasDBid NodeType
 selectNgramsByContextMaster n ucId mcId p = runPGSQuery
                                queryNgramsByContextMaster'
                                  ( ucId
-                                 , ngramsTypeId NgramsTerms
+                                 , toDBid NgramsTerms
                                  , toDBid   NodeDocument
                                  , p
                                  , toDBid   NodeDocument
@@ -378,7 +378,7 @@ selectNgramsByContextMaster n ucId mcId p = runPGSQuery
                                  , n
                                  , mcId
                                  , toDBid   NodeDocument
-                                 , ngramsTypeId NgramsTerms
+                                 , toDBid NgramsTerms
                                  )
 
 -- | TODO fix context_node_ngrams relation

src/Gargantext/Database/Admin/Config.hs

@@ -20,9 +20,9 @@ module Gargantext.Database.Admin.Config
     where
 
 import Control.Lens (view)
-import Data.List (lookup)
-import Data.Text (pack)
 import Gargantext.Core (HasDBid(..))
+import Data.Bimap qualified as Bimap
+import Data.Bimap (Bimap)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
@@ -38,62 +38,10 @@ userArbitrary :: Text
 userArbitrary = "user1"
 
 instance HasDBid NodeType where
-  toDBid  = nodeTypeId
-  fromDBid = fromNodeTypeId
+  toDBid   n   = nodeTypes Bimap.! n -- nodeTypes is total, this cannot fail by construction
+  lookupDBid i = Bimap.lookupR i nodeTypes
 
 
-nodeTypeId :: NodeType -> NodeTypeId
-nodeTypeId n =
-  case n of
-    NodeUser          -> 1
-    NodeFolder        -> 2
-    NodeFolderPrivate -> 20
-    NodeFolderShared  -> 21
-    NodeTeam          -> 210
-    NodeFolderPublic  -> 22
-    NodeCorpusV3      -> 3
-    NodeCorpus        -> 30
-    NodeAnnuaire      -> 31
-    NodeTexts         -> 40
-    NodeDocument      -> 4
-    NodeContact       -> 41
-  --NodeSwap   -> 19
-
-----  Lists
-    NodeList      -> 5
-    NodeListCooc  -> 50
-    NodeModel -> 52
-
-----  Scores
---    NodeOccurrences -> 10
-    NodeGraph       -> 9
-    NodePhylo       -> 90
---    NodeChart       -> 7
-    NodeDashboard   -> 71
---    NodeNoteBook    -> 88
-
-    NodeFile        -> 101
-
-    Notes    -> 991
-    Calc     -> 992
-    NodeFrameNotebook -> 993
-    NodeFrameVisio    -> 994
-
---  Cooccurrences -> 9
---
---  Specclusion  -> 11
---  Genclusion   -> 18
---  Cvalue       -> 12
---
---  TfidfCorpus  -> 13
---  TfidfGlobal  -> 14
---
---  TirankLocal  -> 16
---  TirankGlobal -> 17
-
---  Node management
---  NodeFavorites    -> 15
-
 hasNodeType :: forall a. Node a -> NodeType -> Bool
 hasNodeType n nt = (view node_typename n) == (toDBid nt)
 
@@ -102,12 +50,28 @@ isInNodeTypes n ts = elem (view node_typename n) (map toDBid ts)
 
 -- | Nodes are typed in the database according to a specific ID
 --
-nodeTypeInv :: [(NodeTypeId, NodeType)]
-nodeTypeInv = map swap nodeTypes
-
-nodeTypes :: [(NodeType, NodeTypeId)]
-nodeTypes = [ (n, toDBid n) | n <- allNodeTypes ]
-
-fromNodeTypeId :: NodeTypeId -> NodeType
-fromNodeTypeId tId = fromMaybe (panic $ pack $ "Type Id " <> show tId <> " does not exist")
-                               (lookup tId nodeTypeInv)
+nodeTypes :: Bimap NodeType NodeTypeId
+nodeTypes = Bimap.fromList $ allNodeTypes <&> \n -> case n of
+    NodeUser          -> (n, 1)
+    NodeFolder        -> (n, 2)
+    NodeFolderPrivate -> (n, 20)
+    NodeFolderShared  -> (n, 21)
+    NodeTeam          -> (n, 210)
+    NodeFolderPublic  -> (n, 22)
+    NodeCorpusV3      -> (n, 3)
+    NodeCorpus        -> (n, 30)
+    NodeAnnuaire      -> (n, 31)
+    NodeTexts         -> (n, 40)
+    NodeDocument      -> (n, 4)
+    NodeContact       -> (n, 41)
+    NodeList          -> (n, 5)
+    NodeListCooc      -> (n, 50)
+    NodeModel         -> (n, 52)
+    NodeGraph         -> (n, 9)
+    NodePhylo         -> (n, 90)
+    NodeDashboard     -> (n, 71)
+    NodeFile          -> (n, 101)
+    Notes             -> (n, 991)
+    Calc              -> (n, 992)
+    NodeFrameNotebook -> (n, 993)
+    NodeFrameVisio    -> (n, 994)

src/Gargantext/Database/Admin/Trigger/NodesContexts.hs

@@ -16,11 +16,11 @@ Triggers on NodesNodes table.
 module Gargantext.Database.Admin.Trigger.NodesContexts
   where
 
+-- (ListId, CorpusId, NodeId)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core
-import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
--- (ListId, CorpusId, NodeId)
 import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
 import Gargantext.Prelude
 import qualified Database.PostgreSQL.Simple as DPS
@@ -28,7 +28,7 @@ import qualified Database.PostgreSQL.Simple as DPS
 type MasterListId = ListId
 
 triggerInsertCount :: MasterListId -> DBCmd err Int64
-triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
+triggerInsertCount lId = execPGSQuery query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -64,7 +64,7 @@ triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
 
 
 triggerUpdateAdd :: MasterListId -> DBCmd err Int64
-triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
+triggerUpdateAdd lId = execPGSQuery query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -104,7 +104,7 @@ triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
 
 
 triggerUpdateDel :: MasterListId -> DBCmd err Int64
-triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
+triggerUpdateDel lId = execPGSQuery query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|

src/Gargantext/Database/Admin/Types/Node.hs

@@ -425,7 +425,7 @@ data NodeType = NodeUser
               | Notes | Calc | NodeFrameVisio | NodeFrameNotebook
               | NodeFile
 
-  deriving (Show, Read, Eq, Generic, Bounded, Enum)
+  deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
 
 
 instance GQLType NodeType
@@ -446,7 +446,7 @@ instance ToField NodeType where
 
 
 allNodeTypes :: [NodeType]
-allNodeTypes = [minBound ..]
+allNodeTypes = [minBound .. maxBound]
 
 defaultName :: NodeType -> Text
 defaultName NodeUser       = "User"

src/Gargantext/Database/Query/Table/NodeNgrams.hs

@@ -34,7 +34,7 @@ import Database.PostgreSQL.Simple qualified as PGS (Query, Only(..))
 import Gargantext.Core
 import Gargantext.Core.Types
 import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
-import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId)
+import Gargantext.Database.Schema.Ngrams (NgramsType, fromNgramsTypeId)
 import Gargantext.Database.Schema.NodeNgrams
 import Gargantext.Database.Schema.Prelude (Select, FromRow, sql, fromRow, toField, field, Values(..), QualifiedIdentifier(..), selectTable)
 import Gargantext.Prelude
@@ -82,7 +82,7 @@ insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
                               -> [ toField node_id''
                                  , toField $ toDBid node_subtype
                                  , toField $ ngrams_terms
-                                 , toField $ ngramsTypeId ngrams_type
+                                 , toField $ toDBid ngrams_type
                                  , toField $ fromMaybe 0 ngrams_field
                                  , toField $ fromMaybe 0 ngrams_tag
                                  , toField $ fromMaybe 0 ngrams_class

src/Gargantext/Database/Query/Table/User.hs

@@ -52,10 +52,11 @@ module Gargantext.Database.Query.Table.User
 
 import Control.Arrow (returnA)
 import Control.Lens ((^.), (?~))
+import Data.List.NonEmpty qualified as NE
 import Data.Proxy
 import Data.Time (UTCTime)
 import Data.UUID qualified as UUID
-import Gargantext.Core (HasDBid)
+import Gargantext.Core (HasDBid, toDBid)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key, hu_epo_api_user, hu_epo_api_token)
@@ -70,7 +71,6 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Auth qualified as Auth
 import Opaleye
 import PUBMED.Types qualified as PUBMED
-import qualified Data.List.NonEmpty as NE
 
 ------------------------------------------------------------------------
 -- TODO: on conflict, nice message
@@ -164,7 +164,7 @@ getUsersWithId (RootId i) = map toUserLight <$> runOpaQuery (selectUsersLightWit
     selectUsersLightWithId i' = proc () -> do
       n <- queryNodeTable -< ()
       restrict -< n^.node_id .== pgNodeId i'
-      restrict -< n^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
+      restrict -< n^.node_typename .== sqlInt4 (toDBid NodeUser)
       row      <- queryUserTable -< ()
       restrict -< user_id row .== n^.node_user_id
       returnA  -< row
@@ -192,7 +192,7 @@ getUserHyperdata (UserDBId uId) = do
     selectUserHyperdataWithId i' = proc () -> do
       row      <- queryNodeTable -< ()
       restrict -< row^.node_user_id .== sqlInt4 i'
-      restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
+      restrict -< row^.node_typename .== sqlInt4 (toDBid NodeUser)
       returnA  -< row^.node_hyperdata
 getUserHyperdata _ = undefined
 
@@ -214,7 +214,7 @@ getUserNodeHyperdata (UserDBId uId) = do
     selectUserHyperdataWithId i' = proc () -> do
       row      <- queryNodeTable -< ()
       restrict -< row^.node_user_id .== sqlInt4 i'
-      restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
+      restrict -< row^.node_typename .== sqlInt4 (toDBid NodeUser)
       returnA  -< row
 getUserNodeHyperdata _ = undefined
 

src/Gargantext/Database/Query/Tree.hs

@@ -53,7 +53,7 @@ import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.Core
 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
-import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId)
+import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (runPGSQuery, DBCmd)
@@ -284,7 +284,7 @@ toTree m =
 
 toNodeTree :: DbTreeNode
             -> NodeTree
-toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
+toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromDBid tId) nId
 
 ------------------------------------------------------------------------
 toTreeParent :: [DbTreeNode]
@@ -353,7 +353,7 @@ dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
     SELECT * from tree;
     |] (rootId, In typename)
   where
-    typename = map nodeTypeId ns
+    typename = map toDBid ns
     ns = case nodeTypes of
       [] -> allNodeTypes
       _  -> nodeTypes
@@ -447,7 +447,7 @@ recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId t
     ) SELECT id, typename, parent_id, name FROM recursiveParents ORDER BY original_order DESC;
     |] (nodeId, In typename)
   where
-    typename = map nodeTypeId ns
+    typename = map toDBid ns
     ns = case nodeTypes of
       [] -> allNodeTypes
       _  -> nodeTypes

src/Gargantext/Database/Schema/Ngrams.hs

@@ -24,10 +24,11 @@ import Codec.Serialise (Serialise())
 import Control.Lens (over)
 import Data.Aeson
 import Data.Aeson.Types (toJSONKeyText)
+import Data.Bimap (Bimap)
+import Data.Bimap qualified as Bimap
 import Data.ByteString.Char8 qualified as B
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
-import Data.Map.Strict (fromList, lookup)
 import Data.Text (splitOn, pack, strip)
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
@@ -124,7 +125,7 @@ instance FromField NgramsType where
         else
           returnError ConversionFailed fld dat
 instance ToField NgramsType where
-  toField nt = toField $ ngramsTypeId nt
+  toField nt = toField $ toDBid nt
 
 
 ngramsTypes :: [NgramsType]
@@ -149,22 +150,22 @@ instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
     defaultFromField = fromPGSFromField
 
 pgNgramsType :: NgramsType -> Field SqlInt4
-pgNgramsType = pgNgramsTypeId . ngramsTypeId
+pgNgramsType = pgNgramsTypeId . NgramsTypeId . toDBid
 
 pgNgramsTypeId :: NgramsTypeId -> Field SqlInt4
 pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n
 
-ngramsTypeId :: NgramsType -> NgramsTypeId
-ngramsTypeId Authors     = 1
-ngramsTypeId Institutes  = 2
-ngramsTypeId Sources     = 3
-ngramsTypeId NgramsTerms = 4
+-- | Bidirectional map between an 'NgramsType' and its id.
+-- /NOTE/ This function is total in its domain by construction.
+ngramsTypeIds :: Bimap NgramsType NgramsTypeId
+ngramsTypeIds = Bimap.fromList $ [minBound .. maxBound] <&> \nt -> case nt of
+  Authors     -> (nt, 1)
+  Institutes  -> (nt, 2)
+  Sources     -> (nt, 3)
+  NgramsTerms -> (nt, 4)
 
 fromNgramsTypeId :: NgramsTypeId -> Maybe NgramsType
-fromNgramsTypeId id = lookup id
-                    $ fromList [ (ngramsTypeId nt,nt)
-                               | nt <- [minBound .. maxBound] :: [NgramsType]
-                               ]
+fromNgramsTypeId nid = Bimap.lookupR nid ngramsTypeIds
 
 unNgramsTypeId :: NgramsTypeId -> Int
 unNgramsTypeId (NgramsTypeId i) = i
@@ -173,8 +174,8 @@ toNgramsTypeId :: Int -> NgramsTypeId
 toNgramsTypeId i = NgramsTypeId i
 
 instance HasDBid NgramsType where
-  toDBid   = unNgramsTypeId . ngramsTypeId
-  fromDBid = fromMaybe (panic "NgramsType id not indexed") . fromNgramsTypeId . toNgramsTypeId
+  toDBid nt  = unNgramsTypeId $ ngramsTypeIds Bimap.! nt -- cannot fail
+  lookupDBid = fromNgramsTypeId . toNgramsTypeId
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------