{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Database.Persist.Join
    ( -- * Typeclass
      RunJoin (..)
      -- * One-to-many relation
    , SelectOneMany (..)
    , selectOneMany
    ) where

import Database.Persist.Base
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map
import Data.List (foldl')

class RunJoin a where
    type Result a
    runJoin :: PersistBackend m => a -> m (Result a)

data SelectOneMany one many = SelectOneMany
    { somFilterOne :: [Filter one]
    , somOrderOne :: [Order one]
    , somFilterMany :: [Filter many]
    , somOrderMany :: [Order many]
    , somFilterKeys :: [Key one] -> Filter many
    , somGetKey :: many -> Key one
    , somIncludeNoMatch :: Bool
    }

selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many
selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False
instance (PersistEntity one, PersistEntity many, Ord (Key one))
    => RunJoin (SelectOneMany one many) where
    type Result (SelectOneMany one many) =
        [((Key one, one), [(Key many, many)])]
    runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do
        x <- selectList oneF oneO 0 0
        -- FIXME use select instead of selectList
        y <- selectList (eq (map fst x) : manyF) manyO 0 0
        let y' = foldl' go Map.empty y
        return $ mapMaybe (go' y') x
      where
        go m many@(_, many') =
            Map.insert (getKey many')
            (case Map.lookup (getKey many') m of
                Nothing -> (:) many
                Just v -> v . (:) many
                ) m
        go' y' one@(k, _) =
            case Map.lookup k y' of
                Nothing ->
                    if isOuter
                        then Just (one, [])
                        else Nothing
                Just many -> Just (one, many [])