[ngrams] some more moving of types around

src/Gargantext/API/Ngrams/Types.hs

@@ -194,22 +194,6 @@ instance ToSchema NgramsTable
 --            | OutGroup    NgramsId NgramsId
 --            | SetListType NgramsId ListType
 
-data PatchSet a = PatchSet
-  { _rem :: Set a
-  , _add :: Set a
-  }
-  deriving (Eq, Ord, Show, Generic)
-
-makeLenses ''PatchSet
-makePrisms ''PatchSet
-
-instance ToJSON a => ToJSON (PatchSet a) where
-  toJSON     = genericToJSON     $ unPrefix "_"
-  toEncoding = genericToEncoding $ unPrefix "_"
-
-instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
-  parseJSON = genericParseJSON $ unPrefix "_"
-
 {-
 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
   arbitrary = PatchSet <$> arbitrary <*> arbitrary
@@ -266,55 +250,6 @@ makePrisms ''PM.PatchMap
 
 makePrisms ''PatchMSet
 
-_PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
-_PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
-  where
-    f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
-    f = Map.partition isRem >>> both %~ Map.keysSet
-
-    g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
-    g (rems, adds) = Map.fromSet (const remPatch) rems
-                  <> Map.fromSet (const addPatch) adds
-
-instance Ord a => Action (PatchMSet a) (MSet a) where
-  act (PatchMSet p) (MSet m) = MSet $ act p m
-
-instance Ord a => Applicable (PatchMSet a) (MSet a) where
-  applicable (PatchMSet p) (MSet m) = applicable p m
-
-instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
-  toJSON     = toJSON . view _PatchMSetIso
-  toEncoding = toEncoding . view _PatchMSetIso
-
-instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
-  parseJSON = fmap (_PatchMSetIso #) . parseJSON
-
-instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
-  arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
-
-instance ToSchema a => ToSchema (PatchMSet a) where
-  -- TODO
-  declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
-
-type instance Patched (PatchMSet a) = MSet a
-
-instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
-  arbitrary = uncurry replace <$> arbitrary
-    -- If they happen to be equal then the patch is Keep.
-
-instance ToSchema a => ToSchema (Replace a) where
-  declareNamedSchema (_ :: Proxy (Replace a)) = do
-    -- TODO Keep constructor is not supported here.
-    aSchema <- declareSchemaRef (Proxy :: Proxy a)
-    return $ NamedSchema (Just "Replace") $ mempty
-            & type_ ?~ SwaggerObject
-            & properties .~
-                InsOrdHashMap.fromList
-                [ ("old", aSchema)
-                , ("new", aSchema)
-                ]
-            & required .~ [ "old", "new" ]
-
 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 ngramsElementToRepo
   (NgramsElement { _ne_size     = s
@@ -356,6 +291,12 @@ ngramsElementFromRepo
                 -}
                 }
 
+instance Arbitrary NgramsRepoElement where
+  arbitrary = elements $ map ngramsElementToRepo ns
+    where
+      NgramsTable ns = mockTable
+
+
 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
 reRootChildren root ngram = do
   nre <- use $ at ngram
@@ -389,14 +330,6 @@ reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePa
 
 ------------------------------------------------------------------------
 
-instance Action NgramsTablePatch (Maybe NgramsTableMap) where
-  act p =
-    fmap (execState (reParentNgramsTablePatch p)) .
-    act (p ^. _NgramsTablePatch)
-
-instance Arbitrary NgramsTablePatch where
-  arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
-
 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
@@ -477,17 +410,6 @@ type RepoCmdM   env err m =
 
 
 -- Instances
-instance Arbitrary NgramsRepoElement where
-  arbitrary = elements $ map ngramsElementToRepo ns
-    where
-      NgramsTable ns = mockTable
-
-instance FromHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap))
-  where
-    parseUrlPiece x = maybeToEither x (decode $ cs x)
-
-instance ToHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap)) where
-  toUrlPiece m = cs (encode m)
 
 ngramsTypeFromTabType :: TabType -> SchemaNgrams.NgramsType
 ngramsTypeFromTabType tabType =
@@ -521,3 +443,8 @@ instance ToSchema UpdateTableNgramsCharts where
 ------------------------------------------------------------------------
 type NgramsList = (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap))
 
+instance FromHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap))
+  where
+    parseUrlPiece x = maybeToEither x (decode $ cs x)
+instance ToHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap)) where
+  toUrlPiece m = cs (encode m)

src/Gargantext/Core/Types/Ngrams.hs

+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TypeFamilies      #-}
 
 module Gargantext.Core.Types.Ngrams where
 
@@ -12,7 +15,7 @@ import Data.Hashable (Hashable)
 import qualified Data.HashMap.Strict.InsOrd             as InsOrdHashMap
 import Data.Foldable (foldMap)
 import qualified Data.List as List
-import Data.Map.Strict.Patch (PatchMap)
+import Data.Map.Strict.Patch (PatchMap, fromMap)
 import Data.Patch.Class (Action(..), Applicable(..), Composable, ConflictResolution, ConflictResolutionReplace, Group, MaybePatch(Mod), Patched, PairPatch(..), Replace, Transformable(..))
 import Data.Proxy (Proxy(..))
 import Data.Semigroup (Semigroup)
@@ -119,6 +122,74 @@ newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 unPatchMSet (PatchMSet a) = a
 
+
+data PatchSet a = PatchSet
+  { _rem :: Set a
+  , _add :: Set a
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+makeLenses ''PatchSet
+makePrisms ''PatchSet
+
+instance ToJSON a => ToJSON (PatchSet a) where
+  toJSON     = genericToJSON     $ unPrefix "_"
+  toEncoding = genericToEncoding $ unPrefix "_"
+
+instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
+  parseJSON = genericParseJSON $ unPrefix "_"
+
+
+_PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
+_PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
+  where
+    f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
+    f = Map.partition isRem >>> both %~ Map.keysSet
+
+    g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
+    g (rems, adds) = Map.fromSet (const remPatch) rems
+                  <> Map.fromSet (const addPatch) adds
+
+instance Ord a => Action (PatchMSet a) (MSet a) where
+  act (PatchMSet p) (MSet m) = MSet $ act p m
+
+instance Ord a => Applicable (PatchMSet a) (MSet a) where
+  applicable (PatchMSet p) (MSet m) = applicable p m
+
+instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
+  toJSON     = toJSON . view _PatchMSetIso
+  toEncoding = toEncoding . view _PatchMSetIso
+
+instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
+  parseJSON = fmap (_PatchMSetIso #) . parseJSON
+
+instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
+  arbitrary = (PatchMSet . fromMap) <$> arbitrary
+
+instance ToSchema a => ToSchema (PatchMSet a) where
+  -- TODO
+  declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
+
+type instance Patched (PatchMSet a) = MSet a
+
+instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
+  arbitrary = uncurry replace <$> arbitrary
+    -- If they happen to be equal then the patch is Keep.
+
+instance ToSchema a => ToSchema (Replace a) where
+  declareNamedSchema (_ :: Proxy (Replace a)) = do
+    -- TODO Keep constructor is not supported here.
+    aSchema <- declareSchemaRef (Proxy :: Proxy a)
+    return $ NamedSchema (Just "Replace") $ mempty
+            & type_ ?~ SwaggerObject
+            & properties .~
+                InsOrdHashMap.fromList
+                [ ("old", aSchema)
+                , ("new", aSchema)
+                ]
+            & required .~ [ "old", "new" ]
+
+
 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 
@@ -232,6 +303,12 @@ instance FromField NgramsTablePatch
 instance FromField (PatchMap SchemaNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
   where
     fromField = fromField'
+instance Action NgramsTablePatch (Maybe NgramsTableMap) where
+  act p =
+    fmap (execState (reParentNgramsTablePatch p)) .
+    act (p ^. _NgramsTablePatch)
+instance Arbitrary NgramsTablePatch where
+  arbitrary = NgramsTablePatch <$> fromMap <$> arbitrary