Dynamic.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall #-}

-- | Support dynamic typing.

module Dynamic
  ( Dynamic(..)
  -- * Accessors
  , (!)
  , set
  , modify
  , del
  -- * Input
  , fromJson
  , fromCsv
  , fromCsvNamed
  , fromJsonFile
  , fromCsvFile
  , fromCsvFileNamed
  , fromList
  , fromDict
  -- * Ouput
  , toJson
  , toCsv
  , toCsvNamed
  , toJsonFile
  , toCsvFile
  , toDouble
  , toInt
  , toBool
  , toList
  , toKeys
  , toElems
  -- * Web requests
  , 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

-- | A dynamic error.
data DynamicException
  = DynamicTypeError Text
  | ParseError Text
  | NoSuchKey Text
  | NoSuchIndex Int
  deriving (Show, Typeable)
instance Exception DynamicException

-- | The dynamic type.
data Dynamic
  = Dictionary !(HashMap Text Dynamic)
  | Array !(Vector Dynamic)
  | String !Text
  | Double !Double
  | Bool !Bool
  | Null
  deriving (Eq, Typeable, Data, Generic, Ord)

--------------------------------------------------------------------------------
-- Class instances

-- | Dumps it to JSON.
instance Show Dynamic where
  show = T.unpack . toJson

-- | Converts everything to a double.
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

-- | Treats the dynamic as a double.
instance Enum Dynamic where
  toEnum = Double . fromIntegral
  fromEnum = fromEnum . toDouble

-- | Implemented via 'toDouble'.
instance Real Dynamic where
  toRational = toRational . toDouble

instance Fractional Dynamic where
  fromRational = Double . fromRational
  recip = Double . recip . toDouble

-- | Implemented via 'Double'.
instance Integral Dynamic where
  toInteger = toInteger . toInt
  quotRem x y =
    (Double . fromIntegral *** Double . fromIntegral)
      (quotRem (toInt x) (toInt y))

-- | Makes a 'String'.
instance IsString Dynamic where
  fromString = String . T.pack

-- | Does what you'd expect.
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)

-- | Pretty much a 1:1 correspondance.
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

-- | Produces an array representing a row of columns.
instance Csv.FromRecord Dynamic where
  parseRecord xs = Array <$> traverse Csv.parseField xs

-- | Produces a dictionary representing a row of columns.
instance Csv.FromNamedRecord Dynamic where
  parseNamedRecord xs =
    Dictionary . HM.fromList . map (first T.decodeUtf8) . HM.toList <$>
    traverse Csv.parseField xs

-- | Tries to figure out decimals, coerce true/false into 'Bool', and
-- null into 'Null'.
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))

-- | Renders the elements of containers, or else a singleton.
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

-- | Just works on dictionaries.
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")

-- | Identity for strings, else JSON output.
instance Csv.ToField Dynamic where
  toField =
    \case
      String i -> T.encodeUtf8 i
      other -> L.toStrict (Aeson.encode other)

-- | Nulls are identity, arrays/dicts join, string + double/bool
-- append everything else is @toText x <> toText y@.
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)
  -- Everything else
  x <> y = String (toText x <> toText y)

--------------------------------------------------------------------------------
-- Accessors

-- | @object ! key@ to access the field at key.
(!) :: 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 key value object@ -- set the field's value.
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 k f obj@ -- modify the value at key.
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 k obj@ -- delete the key k in obj.
del :: Dynamic -> Dynamic -> Dynamic
del k obj =
  case obj of
    Dictionary mp -> Dictionary (HM.delete (toText k) mp)
    _ -> throw (DynamicTypeError "Not an object!")

--------------------------------------------------------------------------------
-- Output

toString :: Dynamic -> String
toString = T.unpack . toText

toByteString :: Dynamic -> ByteString
toByteString = T.encodeUtf8 . toText

-- | Convert to string if string, or else JSON encoding.
toText :: Dynamic -> Text
toText =
  \case
    String s -> s
    orelse -> toJson orelse

-- | Convert a dynamic value to a Double.
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.")

-- | Convert a dynamic value to an Int.
toInt :: Dynamic -> Int
toInt = floor . toDouble

-- | Produces a JSON representation of the string.
toJson :: Dynamic -> Text
toJson = T.decodeUtf8 . L.toStrict . Aeson.encodePretty

-- | Produces a JSON representation of the string.
toJsonFile :: FilePath -> Dynamic -> IO ()
toJsonFile fp = L.writeFile fp . Aeson.encodePretty

-- | Produces a JSON representation of the string.
toCsv :: [Dynamic] -> Text
toCsv = T.decodeUtf8 . L.toStrict . Csv.encode

-- | Produces a JSON representation of the string.
toCsvFile :: FilePath -> [Dynamic] -> IO ()
toCsvFile fp = L.writeFile fp . Csv.encode

-- | Produces a JSON representation of the string.
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

-- | Convert to a boolean.
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)

-- | Convert to a list.
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]

-- | Get all the keys.
toKeys :: Dynamic -> [Dynamic]
toKeys =
  \case
    Array v -> V.toList v
    Dictionary kvs -> map String (HM.keys kvs)
    rest -> [rest]

-- | Get all the elems.
toElems :: Dynamic -> [Dynamic]
toElems =
  \case
    Array v -> V.toList v
    Dictionary kvs -> HM.elems kvs
    rest -> [rest]

--------------------------------------------------------------------------------
-- Input

-- | Read JSON into a Dynamic.
fromJson :: Text -> Dynamic
fromJson =
  fromMaybe (throw (ParseError "Unable to parse JSON.")) .
  Aeson.decode . L.fromStrict . T.encodeUtf8

-- | Read CSV into a list of rows with columns (don't use column names).
fromCsv :: Text -> [[Dynamic]]
fromCsv =
  V.toList .
  either (const (throw (ParseError "Unable to parse CSV."))) id .
  Csv.decode Csv.NoHeader . L.fromStrict . T.encodeUtf8

-- | Read CSV into a list of rows (use column names).
fromCsvNamed :: Text -> [Dynamic]
fromCsvNamed =
  V.toList .
  either (const (throw (ParseError "Unable to parse CSV."))) snd .
  Csv.decodeByName . L.fromStrict . T.encodeUtf8

-- | Same as 'fromJson' but from a file.
fromJsonFile :: FilePath -> IO Dynamic
fromJsonFile = fmap fromJson . T.readFile

-- | Same as 'fromCsv' but from a file.
fromCsvFile :: FilePath -> IO [[Dynamic]]
fromCsvFile = fmap fromCsv . T.readFile

-- | Same as 'fromCsvFileNamed' but from a file.
fromCsvFileNamed :: FilePath -> IO [Dynamic]
fromCsvFileNamed = fmap fromCsvNamed . T.readFile

-- | Convert a list of dynamics to a dynamic list.
fromList :: [Dynamic] -> Dynamic
fromList = Array . V.fromList

-- | Convert a list of key/pairs to a dynamic dictionary.
fromDict :: [(Dynamic, Dynamic)] -> Dynamic
fromDict hm = Dictionary (HM.fromList (map (bimap toText id) hm))

--------------------------------------------------------------------------------
-- Web helpers

-- | HTTP GET request for text content.
get ::
     Dynamic
  -> [(Dynamic, Dynamic)] -- ^ Headers.
  -> 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))

-- | HTTP GET request for text content.
getJson ::
     Dynamic
  -> [(Dynamic, Dynamic)] -- ^ Headers.
  -> IO Dynamic
getJson url headers = fmap fromJson (get url headers)

-- | HTTP POST request for text content.
post ::
     Dynamic -- ^ URL.
  -> [(Dynamic, Dynamic)] -- ^ Headers.
  -> Dynamic -- ^ Body.
  -> 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))

-- | HTTP POST request for JSON content.
postJson ::
     Dynamic -- ^ URL.
  -> [(Dynamic, Dynamic)] -- ^ Headers.
  -> Dynamic -- ^ Body.
  -> IO Dynamic
postJson url headers body = fmap fromJson (post url headers body)