duckling/Duckling/Volume/Types.hs

-- Copyright (c) 2016-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree.


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoRebindableSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Duckling.Volume.Types where

import Control.DeepSeq
import Data.Aeson
import Data.Hashable
import Data.Text (Text)
import GHC.Generics
import Prelude
import Duckling.Resolve (Resolve (..))
import qualified Data.Text as Text
import qualified Data.HashMap.Strict as H

data Unit
  = Gallon
  | Hectolitre
  | Litre
  | Centilitre
  | Millilitre
  deriving (Eq, Generic, Hashable, Ord, Show, NFData)

instance ToJSON Unit where
  toJSON = String . Text.toLower . Text.pack . show

data VolumeData = VolumeData
  { value :: Maybe Double
  , unit :: Maybe Unit
  , minValue :: Maybe Double
  , maxValue :: Maybe Double
  }
  deriving (Eq, Generic, Hashable, Ord, Show, NFData)

instance Resolve VolumeData where
  type ResolvedValue VolumeData = VolumeValue
  resolve _ _ VolumeData {value = Just v, unit = Just u} =
    Just (simple u v, False)
  resolve _ _ VolumeData {value = Nothing, unit = Just u
                         , minValue = Just from, maxValue = Just to} =
    Just (between u (from, to), False)
  resolve _ _ VolumeData {value = Nothing, unit = Just u
                         , minValue = Just v, maxValue = Nothing} =
    Just (above u v, False)
  resolve _ _ VolumeData {value = Nothing, unit = Just u
                         , minValue = Nothing, maxValue = Just v} =
    Just (under u v, False)
  resolve _ _ _ = Nothing

data IntervalDirection = Above | Under
  deriving (Eq, Generic, Hashable, Ord, Show, NFData)

data SingleValue = SingleValue
  { vUnit :: Unit
  , vValue :: Double
  }
  deriving (Eq, Show)

instance ToJSON SingleValue where
  toJSON SingleValue {vUnit, vValue} = object
    [ "value" .= vValue
    , "unit"  .= vUnit
    ]

data VolumeValue
  = SimpleValue SingleValue
  | IntervalValue (SingleValue, SingleValue)
  | OpenIntervalValue (SingleValue, IntervalDirection)
  deriving (Show, Eq)

instance ToJSON VolumeValue where
  toJSON (SimpleValue value) = case toJSON value of
    Object o -> Object $ H.insert "type" (toJSON ("value" :: Text)) o
    _ -> Object H.empty
  toJSON (IntervalValue (from, to)) = object
    [ "type" .= ("interval" :: Text)
    , "from" .= toJSON from
    , "to" .= toJSON to
    ]
  toJSON (OpenIntervalValue (from, Above)) = object
    [ "type" .= ("interval" :: Text)
    , "from" .= toJSON from
    ]
  toJSON (OpenIntervalValue (to, Under)) = object
    [ "type" .= ("interval" :: Text)
    , "to" .= toJSON to
    ]

-- -----------------------------------------------------------------
-- Value helpers

simple :: Unit -> Double -> VolumeValue
simple u v = SimpleValue $ single u v

between :: Unit -> (Double, Double) -> VolumeValue
between u (from,to) = IntervalValue (single u from, single u to)

above :: Unit -> Double -> VolumeValue
above = openInterval Above

under :: Unit -> Double -> VolumeValue
under = openInterval Under

openInterval :: IntervalDirection -> Unit -> Double -> VolumeValue
openInterval direction u v = OpenIntervalValue (single u v, direction)

single :: Unit -> Double -> SingleValue
single u v = SingleValue {vUnit = u, vValue = v}