parse a list of different types driven by parser type

parse.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Lib.Parse where

import Control.Lens (Getting, (^?), _Just)
import Data.Aeson (Value)
import Data.Typeable (typeOf)
import Protolude (First, TypeRep, Typeable, panic)

-- | a tuple
data a :*: b = a :*: b deriving (Show, Eq)

infixr 0 :*:

-- | A parser from Value to 'a'
type Preview a = Getting (First a) Value a

-- | A parser that can handle missing values
data Parser a = Parser (Maybe a) (Preview a)

infixr 0 :**:

-- | tuple like collection of parsers
data Q a where
  -- | cons a lens
  (:**:) :: (Typeable a, Typeable b) => Parser a -> Q b -> Q (a :*: b)
  -- | shortcut to avoid L
  (:***:) :: (Typeable a, Typeable b) => Parser a -> Parser b -> Q (a :*: b)
  L :: Typeable a => Parser a -> Q a

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

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

-- | as 'L'
only :: Typeable a => Parser a -> Q a
only = L

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

-- internal parsing
parseG :: Q a -> [(Int, Maybe Value)] -> Either ParseGIssue a
parseG (L l) [v] = parseOne l v
parseG (l :**: ls) (v : vs) = (:*:) <$> parseOne l v <*> parseG ls vs
parseG (l :***: h) [v, w] = (:*:) <$> parseOne l v <*> parseOne h w
parseG _ _ = Left ParseGWrongNumberOfValues

-- | parse a list of values which can be missing
parse ::
    -- | tuple of parsers
    Q a -> 
    -- | list of values 
    [Maybe Value]  -> 
    -- | problems or tuple of parsed values
    Either ParseGIssue a
parse ts = parseG ts . zip [0 ..]

-- apply one parser
parseOne :: forall a. Typeable a => Parser a -> (Int, Maybe Value) -> Either ParseGIssue a
parseOne (Parser m l) (n, v) = case v ^? _Just . l of
  Nothing -> case m of
    Nothing -> Left $ ParseGIssue (n, v, typeOf @a $ panic "no value")
    Just x -> Right x
  Just x -> Right x

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications, OverloadedStrings #-}

module Test.Parse where

import Protolude hiding ((:*:), optional)
import Test.Tasty.HUnit ((@?=))
import Test.Tasty.Hspec (Spec, describe, it)
import Data.Aeson (Value (..))
import Data.Aeson.Lens
import Data.Typeable
import Lib.Parse

spec_generic :: Spec
spec_generic = do
  describe "generic parsers" do
    it "can parse Integer (not very useful)" do
      parse  (only $ required _Integer) [Just $ Number 2] @?= Right 2
    it "can parse String and Integer" do
      parse  (required _String :***: required _Integer) [Just $ String "ciao", Just $ Number 2] @?= Right ("ciao" :*: 2)
    it "can parse Integer, String and Integer" do
      parse  (required _Integer :**: required _String :***: required _Integer) [Just $ Number 3, Just $ String "ciao", Just $ Number 2] @?= Right (3 :*: "ciao" :*: 2)
    it "can parse optional String and Integer" do
      parse  (optional "mega" _String :***: required _Integer) [Nothing, Just $ Number 2] @?= Right ("mega" :*: 2)
    it "can report first issue" do
      parse  (required _String :***: required _Integer) [Just $ Number 3, Just $ Number 2]
        @?= Left (ParseGIssue (0, Just $ Number 3, typeOf @Text $ panic "no value"))
    it "can report first issue" do
      parse  (required _String :***: required _Integer) [Just $ String "ciao", Just $ String "mamma"]
        @?= Left (ParseGIssue (1, Just $ String "mamma", typeOf @Integer $ panic "no value"))
    it "can report wrong number of values" do
      parse  (required _String :***: required _Integer) [Just $ String "ciao", Just $ String "mamma", Nothing]
        @?= Left ParseGWrongNumberOfValues
    it "can report wrong number of values" do
      parse  (required _String :***: required _Integer) [Just $ String "ciao"]
        @?= Left ParseGWrongNumberOfValues