{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall #-}
module Dynamic
( Dynamic(..)
, (!)
, set
, modify
, del
, fromJson
, fromCsv
, fromCsvNamed
, fromJsonFile
, fromCsvFile
, fromCsvFileNamed
, fromList
, fromDict
, toJson
, toCsv
, toCsvNamed
, toJsonFile
, toCsvFile
, toDouble
, toInt
, toBool
, toList
, toKeys
, toElems
, get
, post
, getJson
, postJson
) where
import Control.Arrow ((***))
import Control.Exception
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.Csv as Csv
import Data.Data
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.List
import Data.Maybe
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Generics
import Network.HTTP.Simple
data DynamicException
= DynamicTypeError Text
| ParseError Text
| NoSuchKey Text
| NoSuchIndex Int
deriving (Show, Typeable)
instance Exception DynamicException
data Dynamic
= Dictionary !(HashMap Text Dynamic)
| Array !(Vector Dynamic)
| String !Text
| Double !Double
| Bool !Bool
| Null
deriving (Eq, Typeable, Data, Generic, Ord)
instance Show Dynamic where
show = T.unpack . toJson
instance Num Dynamic where
(toDouble -> x) + (toDouble -> y) = Double (x + y)
(toDouble -> x) * (toDouble -> y) = Double (x * y)
abs = Double . abs . toDouble
signum = Double . signum . toDouble
fromInteger = Double . fromInteger
negate = Double . negate . toDouble
instance Enum Dynamic where
toEnum = Double . fromIntegral
fromEnum = fromEnum . toDouble
instance Real Dynamic where
toRational = toRational . toDouble
instance Fractional Dynamic where
fromRational = Double . fromRational
recip = Double . recip . toDouble
instance Integral Dynamic where
toInteger = toInteger . toInt
quotRem x y =
(Double . fromIntegral *** Double . fromIntegral)
(quotRem (toInt x) (toInt y))
instance IsString Dynamic where
fromString = String . T.pack
instance Aeson.FromJSON Dynamic where
parseJSON =
\case
Aeson.Array a -> Array <$> traverse Aeson.parseJSON a
Aeson.Number sci -> pure (Double (realToFrac sci))
Aeson.Bool v -> pure (Bool v)
Aeson.Null -> pure Null
Aeson.Object hm -> fmap Dictionary (Aeson.parseJSON (Aeson.Object hm))
Aeson.String s -> pure (String s)
instance Aeson.ToJSON Dynamic where
toJSON =
\case
Dictionary v -> Aeson.toJSON v
Array v -> Aeson.toJSON v
String t -> Aeson.toJSON t
Double t -> Aeson.toJSON t
Bool t -> Aeson.toJSON t
Null -> Aeson.toJSON Aeson.Null
instance Csv.FromRecord Dynamic where
parseRecord xs = Array <$> traverse Csv.parseField xs
instance Csv.FromNamedRecord Dynamic where
parseNamedRecord xs =
Dictionary . HM.fromList . map (first T.decodeUtf8) . HM.toList <$>
traverse Csv.parseField xs
instance Csv.FromField Dynamic where
parseField bs =
case T.decimal text of
Left {} ->
case T.toLower (T.strip text) of
"true" -> pure (Bool True)
"false" -> pure (Bool False)
"null" -> pure Null
_ -> asString
Right (v, _) -> pure v
where
text = T.decodeUtf8 bs
asString = pure (String (T.decodeUtf8 bs))
instance Csv.ToRecord Dynamic where
toRecord =
\case
Dictionary hm -> V.map Csv.toField (V.fromList (HM.elems hm))
Array vs -> V.map Csv.toField vs
String s -> V.singleton (T.encodeUtf8 s)
Double d -> V.singleton (Csv.toField d)
Bool d -> V.singleton (Csv.toField (Bool d))
Null -> mempty
instance Csv.ToNamedRecord Dynamic where
toNamedRecord =
\case
Dictionary hm ->
HM.fromList (map (bimap T.encodeUtf8 Csv.toField) (HM.toList hm))
_ -> throw (TypeError "Can't make a CSV row out of a non-dictionary")
instance Csv.ToField Dynamic where
toField =
\case
String i -> T.encodeUtf8 i
other -> L.toStrict (Aeson.encode other)
instance Semigroup Dynamic where
Null <> x = x
x <> Null = x
Array xs <> Array ys = Array (xs <> ys)
Dictionary x <> Dictionary y = Dictionary (x <> y)
String x <> String y = String (x <> y)
String x <> Double y = String (x <> toText (Double y))
Double x <> String y = String (toText (Double x) <> y)
String x <> Bool y = String (x <> toText (Bool y))
Bool x <> String y = String (toText (Bool x) <> y)
x <> y = String (toText x <> toText y)
(!) :: Dynamic -> Dynamic -> Dynamic
(!) obj k =
case obj of
Dictionary mp ->
case HM.lookup (toText k) mp of
Nothing -> Null
Just v -> v
Array v ->
case v V.!? toInt k of
Nothing -> Null
Just el -> el
String str -> String (T.take 1 (T.drop (toInt k) str))
_ -> throw (DynamicTypeError "Can't index this type of value.")
infixl 9 !
set :: Dynamic -> Dynamic -> Dynamic -> Dynamic
set k v obj =
case obj of
Dictionary mp -> Dictionary (HM.insert (toText k) v mp)
_ -> throw (DynamicTypeError "Not an object!")
modify :: Dynamic -> (Dynamic -> Dynamic) -> Dynamic -> Dynamic
modify k f obj =
case obj of
Dictionary mp -> Dictionary (HM.adjust f (toText k) mp)
_ -> throw (DynamicTypeError "Not an object!")
del :: Dynamic -> Dynamic -> Dynamic
del k obj =
case obj of
Dictionary mp -> Dictionary (HM.delete (toText k) mp)
_ -> throw (DynamicTypeError "Not an object!")
toString :: Dynamic -> String
toString = T.unpack . toText
toByteString :: Dynamic -> ByteString
toByteString = T.encodeUtf8 . toText
toText :: Dynamic -> Text
toText =
\case
String s -> s
orelse -> toJson orelse
toDouble :: Dynamic -> Double
toDouble =
\case
String t ->
case T.double t of
Left {} ->
throw (DynamicTypeError ("Couldn't treat string as number: " <> t))
Right (v, _) -> v
Double d -> d
Bool {} -> throw (DynamicTypeError "Can't treat bool as number.")
Null -> 0
Dictionary {} ->
throw (DynamicTypeError "Can't treat dictionary as number.")
Array {} -> throw (DynamicTypeError "Can't treat array as number.")
toInt :: Dynamic -> Int
toInt = floor . toDouble
toJson :: Dynamic -> Text
toJson = T.decodeUtf8 . L.toStrict . Aeson.encodePretty
toJsonFile :: FilePath -> Dynamic -> IO ()
toJsonFile fp = L.writeFile fp . Aeson.encodePretty
toCsv :: [Dynamic] -> Text
toCsv = T.decodeUtf8 . L.toStrict . Csv.encode
toCsvFile :: FilePath -> [Dynamic] -> IO ()
toCsvFile fp = L.writeFile fp . Csv.encode
toCsvNamed :: [Dynamic] -> Text
toCsvNamed xs = rows xs
where
rows = T.decodeUtf8 . L.toStrict . Csv.encodeByName (makeHeader xs)
makeHeader rs =
case rs of
(Dictionary hds:_) -> V.fromList (map T.encodeUtf8 (HM.keys hds))
_ -> mempty
toBool :: Dynamic -> Bool
toBool =
\case
Dictionary m -> not (HM.null m)
Array v -> not (V.null v)
Bool b -> b
Double 0 -> False
Double {} -> True
Null -> False
String text ->
case T.toLower (T.strip text) of
"true" -> True
"false" -> False
_ -> not (T.null text)
toList :: Dynamic -> [Dynamic]
toList =
\case
Array v -> V.toList v
Dictionary kvs ->
map
(\(k, v) -> Dictionary (HM.fromList [("key", String k), ("value", v)]))
(HM.toList kvs)
rest -> [rest]
toKeys :: Dynamic -> [Dynamic]
toKeys =
\case
Array v -> V.toList v
Dictionary kvs -> map String (HM.keys kvs)
rest -> [rest]
toElems :: Dynamic -> [Dynamic]
toElems =
\case
Array v -> V.toList v
Dictionary kvs -> HM.elems kvs
rest -> [rest]
fromJson :: Text -> Dynamic
fromJson =
fromMaybe (throw (ParseError "Unable to parse JSON.")) .
Aeson.decode . L.fromStrict . T.encodeUtf8
fromCsv :: Text -> [[Dynamic]]
fromCsv =
V.toList .
either (const (throw (ParseError "Unable to parse CSV."))) id .
Csv.decode Csv.NoHeader . L.fromStrict . T.encodeUtf8
fromCsvNamed :: Text -> [Dynamic]
fromCsvNamed =
V.toList .
either (const (throw (ParseError "Unable to parse CSV."))) snd .
Csv.decodeByName . L.fromStrict . T.encodeUtf8
fromJsonFile :: FilePath -> IO Dynamic
fromJsonFile = fmap fromJson . T.readFile
fromCsvFile :: FilePath -> IO [[Dynamic]]
fromCsvFile = fmap fromCsv . T.readFile
fromCsvFileNamed :: FilePath -> IO [Dynamic]
fromCsvFileNamed = fmap fromCsvNamed . T.readFile
fromList :: [Dynamic] -> Dynamic
fromList = Array . V.fromList
fromDict :: [(Dynamic, Dynamic)] -> Dynamic
fromDict hm = Dictionary (HM.fromList (map (bimap toText id) hm))
get ::
Dynamic
-> [(Dynamic, Dynamic)]
-> IO Text
get url headers = do
response <-
httpBS
(foldl'
(\r (k, v) ->
addRequestHeader (fromString (toString k)) (toByteString v) r)
(addRequestHeader
"User-Agent"
"haskell-dynamic"
(fromString (toString url)))
headers)
pure (T.decodeUtf8 (getResponseBody response))
getJson ::
Dynamic
-> [(Dynamic, Dynamic)]
-> IO Dynamic
getJson url headers = fmap fromJson (get url headers)
post ::
Dynamic
-> [(Dynamic, Dynamic)]
-> Dynamic
-> IO Text
post url headers body = do
response <-
httpBS
(foldl'
(\r (k, v) ->
addRequestHeader (fromString (toString k)) (toByteString v) r)
(addRequestHeader
"User-Agent"
"haskell-dynamic"
(setRequestMethod
"POST"
(setRequestBodyJSON body (fromString (toString url)))))
headers)
pure (T.decodeUtf8 (getResponseBody response))
postJson ::
Dynamic
-> [(Dynamic, Dynamic)]
-> Dynamic
-> IO Dynamic
postJson url headers body = fmap fromJson (post url headers body)