FromJSON orphans for Sound.OSC types in the hosc-json package

Orphan.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Sound.OSC.Type.JSON.Orphan.Black where

import           BasePrelude
import           Data.Aeson
import           Data.Aeson.Types
import           Sound.OSC.Type

import           Data.Vector ((!?))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Vector as Vector

foo :: BSL.ByteString
foo = "[\"#bundle\",{\"timestamp\":0.0},[\"/c_set\",3,4.5],[\"/n_free\",0]]"

(.!) :: FromJSON a => Array -> Int -> Parser a
v .! ix = case v !? ix of
  Just a ->
    parseJSON a
  Nothing ->
    fail ("No such index " <> show ix <> " in vector " <> show v)

-- | This differs from decode_datum in that it always parses numbers
-- to a Double.
instance FromJSON Datum where
  parseJSON (Object o) =
    parseBlob <|> parseMIDI <|> parseTimestamp
    where
      parseBlob =
        Blob . BSL.pack <$> o .: "blob"
      parseMIDI = do
        [p, q, r, s] <- o .: "midi"
        return (midi (p, q, r, s))
      parseTimestamp =
        TimeStamp <$> (o .: "timestamp")
  parseJSON whole@(Number _) =
    Double <$> parseJSON whole
  parseJSON whole@(String _) =
    string <$> parseJSON whole
  parseJSON invalid =
    typeMismatch "Datum" invalid

instance FromJSON Bundle where
  parseJSON (Array v) = do
    b' <- v .! 0
    timestamp <- v .! 1
    guard (b' == String "#bundle")
    Bundle <$> (timestamp .: "timestamp") <*> traverse parseMessages (toList (Vector.drop 2 v))
    where
      parseMessages (Array w) = do
        addr <- w .! 0
        Message <$> parseJSON addr <*> traverse parseJSON (toList (Vector.drop 1 w))
      parseMessages invalid =
        typeMismatch "Bundle' messages" invalid
  parseJSON invalid =
    typeMismatch "Bundle'" invalid