NestHydration.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- |
module NestHydration where

import Control.Lens
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust, fromJust, catMaybes, listToMaybe, mapMaybe, maybeToList)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Traversable (for)
import Control.Monad
import qualified Data.Aeson as J
import Data.Foldable
import Data.Functor ((<&>))
import Data.Vector.Generic.Mutable (growFront)
import Data.List (groupBy)
import Control.Arrow ((&&&))
import Data.Monoid
import qualified Data.Vector as V
import Text.Pretty.Simple (pPrint, ColorOptions (colorRainbowParens))
import Data.Data (Data)

--------------------------------------------------------------------------------
    
type Row = Map Text J.Value
type Entry = Map Text J.Value

data Property = Property PBase | PropertyObject PObject | PropertyArray PArray 
  deriving Show

data PArray = PArray { _paName :: Text, _paProperties :: [Property] } deriving Show
data PObject = PObject { _poName :: Text, _poProperties :: [Property] } deriving Show
data PBase = PBase { _pbName :: Text, _pbColumn :: Text, _pbIsId :: Bool } deriving Show

makeLenses ''PArray
makeLenses ''PObject
makeLenses ''PBase
makePrisms ''Property

--------------------------------------------------------------------------------

nest :: [Property] -> [Row] -> [Entry]
nest properties rows = do
  -- 1) Hydrate One To One Object Nested Relations for all rows.
  let entries = nestEntries properties rows

  -- 2) Extract Primary Keys from '[Property]'
  let primaryKeys = toListOf (folded . _Property . filtered _pbIsId . pbColumn) properties

  ---- 3) Group all rows whose primary key fields match 
  let groupedEntries = groupBy (groupPredicate primaryKeys) entries

  ---- 4) Extract Array Properties from '[Property]'
  let arrayProperties = toListOf (folded . _PropertyArray) properties

  ---- 5) Build subfields for each array relation
  mapMaybe (foldGroupedEntries arrayProperties) groupedEntries

--------------------------------------------------------------------------------
-- One To Many (Array Relationships)
 
-- | Collapse a grouped set of Entries into a single 'Entry' with
-- array relationship fields inserted.
foldGroupedEntries :: [PArray] -> [(Row, Entry)] -> Maybe Entry
foldGroupedEntries parrays entries@(entry:_) = 
  let initialFields = snd entry
      arrayFields = foldMap (fmap J.toJSON . flip buildSubfieldArray entries) parrays
   in Just $ initialFields <> arrayFields
foldGroupedEntries parrays _ = Nothing 

-- | Create a singleton 'Map' from the Array field Alias to a list of subfield entries.
buildSubfieldArray :: PArray -> [(Row, Entry)] -> Map Text [Entry]
buildSubfieldArray pa@PArray {..} entries =
  Map.singleton _paName (fmap (buildSubfield pa) $ fmap fst entries)

-- | Construct a Map of columns described in the Array Property.
buildSubfield :: PArray -> Row -> Entry
buildSubfield PArray {..} row =
  let aliasMap = Map.fromList $ fmap (view pbName &&& view pbColumn) $ toListOf (folded . _Property) _paProperties
  in Map.compose row aliasMap

-- | Group '(Row, Entry)' elements by primary keys.
groupPredicate :: [Text] -> (Row, Entry) -> (Row, Entry) -> Bool
groupPredicate colNames (_, entry1) (_, entry2) =
  let keys1 = Map.filterWithKey (\k _ -> k `elem` colNames) entry1
      keys2 = Map.filterWithKey (\k _ -> k `elem` colNames) entry2
  in keys1 == keys2

--------------------------------------------------------------------------------
-- One To One (Object Relationships)

nestEntries :: [Property] -> [Row] -> [(Row, Entry)]
nestEntries properties rows = do
  row <- rows
  maybe mempty (pure . (row,)) $ nestEntry properties row
  
nestEntry :: [Property] -> Row -> Maybe Entry
nestEntry properties row = do
  let pkCols :: [PBase]
      pkCols = catMaybes $ properties <&> \case
         Property pb@PBase {..} | _pbIsId == True -> Just pb
         _ -> Nothing
  entry <- buildEntry pkCols row
  getAp $ foldMap (Ap . dispatchExtract row entry) properties

dispatchExtract :: Row -> Entry -> Property -> Maybe Entry
dispatchExtract row mappedEntry = \case
  Property PBase {..} -> do
    col <- Map.lookup _pbColumn row
    pure $ Map.insert _pbName col mappedEntry 
  PropertyObject PObject {..} -> do
    newEntry <- getAp $ foldMap (Ap . dispatchExtract row mempty) _poProperties
    pure $ Map.insert _poName (J.toJSON newEntry) mappedEntry
  PropertyArray PArray {..} -> do
      newEntry <- getAp $ foldMap (Ap . dispatchExtract row mempty) _paProperties
      pure $ Map.insert _paName (J.toJSON newEntry) mappedEntry

-- | For a given 'Row', construct a new 'Map' with a key for each
-- primary ID 'Property'.
buildEntry :: [PBase] -> Map Text J.Value -> Maybe (Map Text J.Value)
buildEntry cols row = foldM f mempty cols
  where
    f :: Entry -> PBase -> Maybe Entry
    f entry (_pbColumn -> key) = case Map.lookup key row of
      Nothing -> Nothing
      Just val -> Just $ Map.insert key val entry
  
--------------------------------------------------------------------------------
-- Sample Data

fakeRow1 :: Map Text J.Value
fakeRow1 =
  Map.fromList
    [ ("id", J.Number 42)
    , ("name", J.String "Album 1")
    , ("artist_id", J.Number 1)
    , ("artist_name", J.String "Artist 1")
    , ("track_id", J.Number 1)
    , ("track_title", J.String "Track 1")
    , ("artist_record_label_id", J.Number 5)
    , ("artist_record_label_name", J.String "No Limit Records")
    , ("track_producer_id", J.Number 33)
    , ("track_producer_name", J.String "Big Mike")
    ]

fakeRow2 :: Map Text J.Value
fakeRow2 =
  Map.fromList
    [ ("id", J.Number 42)
    , ("name", J.String "Album 1")
    , ("artist_id", J.Number 1)
    , ("artist_name", J.String "Artist 1")
    , ("track_id", J.Number 3)
    , ("track_title", J.String "Track 3")
    , ("artist_record_label_id", J.Number 5)
    , ("artist_record_label_name", J.String "No Limit Records")
    , ("track_producer_id", J.Number 32)
    , ("track_producer_name", J.String "Lil Freddy")
    ]

fakeProperties :: [Property]
fakeProperties =
  [ Property (PBase "name" "name" False)
  , Property (PBase "id" "id" True)
  , PropertyArray
      (PArray "tracks"
         [ Property (PBase "track_id" "track_id" True)
         , Property (PBase "track_title" "track_title" False)
         , PropertyObject
             (PObject "producer"
               [ Property (PBase "producer_name" "track_producer_name" False)
               , Property (PBase "producer_id" "track_producer_id" True)
               ])
         ])
  , PropertyObject
      (PObject "artist"
         [ Property (PBase "artist_name" "artist_name" False)
         , Property (PBase "artist_id" "artist_id" True)
         , PropertyObject
            (PObject "record_label"
              [ Property (PBase "label_name" "artist_record_label_name" False)
              , Property (PBase "label_id" "artist_record_label_id" True)
              ])
         ])
  ]

--------------------------------------------------------------------------------

main :: IO ()
main = traverse_ (pPrint . J.toJSON) $ nest fakeProperties [fakeRow1, fakeRow2]