{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module JSOP.Parse where

import Control.Lens (Getting, (%~), (^?), _1)
import Data.Aeson (Value)
import Data.Aeson.Lens
import qualified Data.Map.Monoidal.Strict as Mm
import Generics.SOP
import Trie
import Protolude hiding (All)
import Data.Typeable (typeOf)


type Preview a = Getting (First a) Value a

-- | A parser that can handle missing values
data Parser p a = Parser
  { parser_path :: p
  , parser_default :: Maybe a
  , parser_prism :: Preview a
  }

-- | shortcut for a parser that handle missing values
required :: p -> Preview a -> Parser p a
required path = Parser path Nothing

-- | shortcut for parsers that have a default if value is missing
optional :: p -> a -> Preview a -> Parser p a
optional path = Parser path . Just

-- | what wrong can happen
data ParseGIssue
  = ParseGIssue (Int, Maybe Value, TypeRep)
  | ParseGWrongNumberOfValues
  deriving (Eq, Show)

jSOP
  :: (All Typeable xs, IsProductType a xs)
  => (path -> [Text])
  -> NP (Parser path) xs -- ^ parsers for the indexed subvalues
  -> Value -- ^ json structure
  -> Either ParseGIssue a
jSOP splitter ps value = maybe
  do Left ParseGWrongNumberOfValues
  do
    fmap productTypeTo
      . hsequence
      . hcliftA2 (Proxy :: Proxy Typeable) parseSField ps
  do fromList $ zip [0 ..] $ getValues splitter paths value
  where
    paths = hcollapse $ hmap (K . parser_path) ps

parseSField :: forall a p. Typeable a => Parser p a -> K (Int, Maybe Value) a -> Either ParseGIssue a
parseSField (Parser _ md parser) (K (n, v)) = case v of
  Nothing -> case md of
    Just x -> Right x
    Nothing -> Left $ ParseGIssue (n, v, typeOf @a $ panic "no value")
  Just w -> case w ^? parser of
    Nothing -> Left $ ParseGIssue (n, v, typeOf @a $ panic "cannot parse")
    Just r -> Right r

--------------------------------------------------------------------------------------------
-- memoize a trie to resolve path queries
--------------------------------------------------------------------------------------------
type Paths = Trie Text (First Int, [Int])

mkPath :: Int -> [Text] -> Paths
mkPath n =
  foldr
    (fmap (Trie (First Nothing, [n])) . Mm.singleton)
    (Trie (First (Just n), [n]) mempty)

mkPaths :: [[Text]] -> Paths
mkPaths = foldMap (uncurry mkPath) . zip [0 ..]

treequery :: Paths -> Value -> ([(Int, Value)], [Int])
treequery (Trie (m, _ns) qs) v =
  appEndo (foldMap (\n -> Endo $ _1 %~ (:) (n, v)) m) $
    fold $ do
      (k, t) <- Mm.assocs qs
      pure $ case v ^? key k of
        Nothing -> ([], snd $ load t)
        Just w -> treequery t w

-- | close over paths argument to get an efficient Value -> [Maybe Value]
getValues :: (p -> [Text]) -> [p] -> Value -> [Maybe Value]
getValues splitter ts v =
  let (positive, negative) = treequery (mkPaths $ splitter <$> ts) v
   in fmap snd $
        sortOn fst $
          fmap (,Nothing) negative <> fmap (fmap Just) positive