1 {-# LANGUAGE OverloadedStrings, FunctionalDependencies, ScopedTypeVariables #-}
    2 {-# OPTIONS_GHC -fno-warn-orphans #-}
    3 module JSON
    4   ( module Data.Aeson
    5   , module Data.Aeson.Types
    6   , ToObject
    7   -- -- , objectEncoding
    8   , mapObjects
    9   , ToNestedObject(..)
   10   , (.=.)
   11   , omitIfNothing
   12   , kvObjectOrEmpty-- , (.=?)
   13   , lookupAtParse-- , (.!)
   14   -- , (.!?)
   15   , Record(..)
   16   , foldObjectIntoRec -- , (.<>)
   17   , recordObject
   18   , recordEncoding
   19   , mapRecords
   20   , (.=:)
   21   , recordMap
   22   -- -- , eitherJSON
   23   , Query
   24   , jsonQuery
   25   -- -- , escapeByteString
   26   ) where
   27 
   28 import Data.Aeson
   29 import Data.Aeson.Types
   30 import Data.Aeson.Text (encodeToTextBuilder)
   31 import qualified Data.ByteString as BS
   32 import qualified Data.HashMap.Strict as HM
   33 import Data.Monoid ((<>))
   34 import qualified Data.Text as T
   35 import qualified Data.Text.Encoding as TE
   36 import qualified Data.Text.Lazy as TL
   37 import qualified Data.Text.Lazy.Builder as TLB
   38 import qualified Data.Vector as V
   39 import Network.HTTP.Types (Query)
   40 import qualified Text.Blaze.Html as Html
   41 import qualified Text.Blaze.Html.Renderer.Text as Html
   42 
   43 newtype UnsafeEncoding = UnsafeEncoding Encoding
   44 
   45 instance KeyValue [Pair] where
   46   k .= v = [k .= v]
   47 
   48 instance KeyValue Object where
   49   k .= v = HM.singleton k $ toJSON v
   50 
   51 class (Monoid o, KeyValue o) => ToObject o
   52 
   53 instance ToObject Series
   54 instance ToObject [Pair]
   55 instance ToObject Object
   56 
   57 mapObjects :: (Functor t, Foldable t) => (a -> Series) -> t a -> Encoding
   58 mapObjects f = foldable . fmap (UnsafeEncoding . pairs . f)
   59 
   60 class (ToObject o, ToJSON u) => ToNestedObject o u | o -> u where
   61   nestObject :: ToJSON v => T.Text -> ((o -> u) -> v) -> o
   62 
   63 instance ToJSON UnsafeEncoding where
   64   toJSON = error "toJSON UnsafeEncoding"
   65   toEncoding (UnsafeEncoding e) = e
   66 
   67 instance ToNestedObject Series UnsafeEncoding where
   68   nestObject k f = k .= f (UnsafeEncoding . pairs)
   69 
   70 instance ToNestedObject [Pair] Value where
   71   nestObject k f = k .= f object
   72 
   73 instance ToNestedObject Object Value where
   74   nestObject k f = k .= f Object
   75 
   76 infixr 8 .=.
   77 (.=.) :: ToNestedObject o u => T.Text -> o -> o
   78 k .=. v = nestObject k (\f -> f v)
   79 
   80 -- | Utility to build pairs that omit nothing values.
   81 -- Replace with generic deriving instances later.
   82 omitIfNothing :: (ToJSON v) => T.Text -> Maybe v -> [Pair]
   83 _ `omitIfNothing` Nothing = []
   84 k `omitIfNothing` (Just v) = [k .= v]
   85 
   86 -- infixr 8 .=?
   87 -- (.=?) :: (ToObject o, ToJSON v) => T.Text -> Maybe v -> o
   88 kvObjectOrEmpty :: (ToObject o, ToJSON v) => T.Text -> Maybe v -> o
   89 _ `kvObjectOrEmpty` Nothing = mempty
   90 k `kvObjectOrEmpty` (Just v) = k .= v
   91 
   92 data Record k o = Record
   93   { recordKey :: !k
   94   , _recordObject :: o
   95   }
   96 
   97 -- fold object into key + object
   98 -- infixl 5 .<>
   99 foldObjectIntoRec :: Monoid o => Record k o -> o -> Record k o
  100 Record key obj `foldObjectIntoRec` obj2 = Record key $ obj <> obj2
  101 
  102 recordObject :: (ToJSON k, ToObject o) => Record k o -> o
  103 recordObject (Record k o) = ("id" .= k) <> o
  104 
  105 recordEncoding :: ToJSON k => Record k Series -> Encoding
  106 recordEncoding = pairs . recordObject
  107 
  108 mapRecords :: (Functor t, Foldable t, ToJSON k) => (a -> Record k Series) -> t a -> Encoding
  109 mapRecords toRecord objs = mapObjects (recordObject . toRecord) objs
  110 
  111 infixr 8 .=:
  112 (.=:) :: (ToJSON k, ToNestedObject o u) => T.Text -> Record k o -> o
  113 (.=:) k = (.=.) k . recordObject
  114 
  115 recordMap :: (ToJSON k, ToNestedObject o u) => [Record k o] -> o
  116 recordMap = foldMap (\r -> tt (toJSON $ recordKey r) .=. recordObject r) where
  117   tt (String t) = t
  118   tt v = TL.toStrict $ TLB.toLazyText $ encodeToTextBuilder v
  119 
  120 lookupAtParse :: FromJSON a => Array -> Int -> Parser a
  121 a `lookupAtParse` i = maybe (fail $ "index " ++ show i ++ " out of range") parseJSON $ a V.!? i
  122 
  123 instance ToJSON BS.ByteString where
  124   toJSON = String . TE.decodeUtf8 -- questionable
  125 
  126 instance ToJSONKey BS.ByteString where
  127   toJSONKey = toJSONKeyText TE.decodeUtf8
  128 
  129 instance FromJSON BS.ByteString where
  130   parseJSON = fmap TE.encodeUtf8 . parseJSON
  131 
  132 instance ToJSON Html.Html where
  133   toJSON = toJSON . Html.renderHtml
  134   toEncoding = toEncoding . Html.renderHtml
  135 
  136 jsonQuery :: Monad m => (BS.ByteString -> Maybe BS.ByteString -> m (Maybe Encoding)) -> Query -> m Series
  137 jsonQuery _ [] =
  138   return mempty
  139 jsonQuery f ((k,mVal):qryPairs) = do
  140   mEncoded :: Maybe Encoding <- f k mVal
  141   let jsonQueryRestAct = jsonQuery f qryPairs
  142   maybe
  143      (id :: Series -> Series)
  144      (\encodedObj seriesRest -> (objToPair k encodedObj) <> seriesRest)
  145      mEncoded
  146     <$> jsonQueryRestAct
  147   where
  148     objToPair :: (KeyValue kv) => BS.ByteString -> Encoding -> kv
  149     objToPair key encObj = ((TE.decodeLatin1 key .=) . UnsafeEncoding) encObj