Type.hs

{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language LambdaCase #-}
{-# language MonoLocalBinds #-}
{-# language MultiWayIf #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language UndecidableInstances #-}

module Rel8.Type
  ( DBType (typeInformation)
  )
where

-- aeson
import Data.Aeson ( Value )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Text as Aeson

-- attoparsec
import qualified Data.Attoparsec.ByteString.Char8 as A

-- base
import Control.Applicative ((<|>))
import Data.Fixed (Fixed)
import Data.Functor.Contravariant ((>$<))
import Data.Int (Int16, Int32, Int64)
import Data.List.NonEmpty ( NonEmpty )
import Data.Kind ( Constraint, Type )
import Prelude
import Text.Read (readMaybe)

-- bytestring
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as Lazy ( ByteString )
import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )
import qualified Data.ByteString.Builder as B
import Data.ByteString.Builder.Prim (primBounded)

-- case-insensitive
import Data.CaseInsensitive ( CI )
import qualified Data.CaseInsensitive as CI

-- hasql
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders

-- iproute
import Data.IP (IPRange)

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )

-- rel8
import Rel8.Schema.Null ( NotNull, Sql, nullable )
import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
import Rel8.Type.Decimal (PowerOf10, resolution)
import Rel8.Type.Decoder (Decoder (..))
import Rel8.Type.Encoder (Encoder (..))
import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
import Rel8.Type.Name (TypeName (..))
import Rel8.Type.Parser (parse)
import qualified Rel8.Type.Builder.ByteString as Builder
import qualified Rel8.Type.Parser.ByteString as Parser
import qualified Rel8.Type.Builder.Time as Builder
import qualified Rel8.Type.Parser.Time as Parser

-- scientific
import Data.ByteString.Builder.Scientific (scientificBuilder)
import Data.Scientific (Scientific)

-- text
import Data.Text ( Text )
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8Builder)
import qualified Data.Text.Lazy as Lazy (Text, unpack)
import qualified Data.Text.Lazy as Text (fromStrict, toStrict)

-- time
import Data.Time.Calendar (Day)
import Data.Time.Clock (DiffTime, UTCTime)
import Data.Time.LocalTime
  ( CalendarDiffTime (CalendarDiffTime)
  , LocalTime
  , TimeOfDay
  )
import Data.Time.Format (formatTime, defaultTimeLocale)

-- utf8
import qualified Data.ByteString.UTF8 as UTF8

-- uuid
import Data.UUID ( UUID )
import qualified Data.UUID as UUID


-- | Haskell types that can be represented as expressions in a database. There
-- should be an instance of @DBType@ for all column types in your database
-- schema (e.g., @int@, @timestamptz@, etc).
-- 
-- Rel8 comes with stock instances for most default types in PostgreSQL, so you
-- should only need to derive instances of this class for custom database
-- types, such as types defined in PostgreSQL extensions, or custom domain
-- types.
type DBType :: Type -> Constraint
class NotNull a => DBType a where
  typeInformation :: TypeInformation a


-- | Corresponds to @bool@
instance DBType Bool where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.bool
          , text = \case
              False -> "f"
              True -> "t"
          , quote = Opaleye.ConstExpr . Opaleye.BoolLit
          }
    , decode =
        Decoder
          { binary = Decoders.bool
          , text = \case
              "t" -> pure True
              "f" -> pure False
              input -> Left $ "bool: bad bool " <> show input
          }
    , delimiter = ','
    , typeName = "bool"
    }


-- | Corresponds to @char@
instance DBType Char where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.char
          , text = B.charUtf8
          , quote = Opaleye.ConstExpr . Opaleye.StringLit . pure
          }
    , decode = 
        Decoder
          { binary = Decoders.char
          , text = \input -> case UTF8.uncons input of
              Just (char, rest) | BS.null rest -> pure char
              _ -> Left $ "char: bad char " <> show input
          }
    , delimiter = ','
    , typeName =
        TypeName
          { name = "bpchar"
          , modifiers = ["1"]
          , arrayDepth = 0
          }
    }


-- | Corresponds to @int2@
instance DBType Int16 where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.int2
          , text = B.int16Dec
          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
          }
    , decode =
        Decoder
          { binary = Decoders.int2
          , text = parse (A.signed A.decimal)
          }
    , delimiter = ','
    , typeName = "int2"
    }


-- | Corresponds to @int4@
instance DBType Int32 where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.int4
          , text = B.int32Dec
          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
          }
    , decode =
        Decoder
          { binary = Decoders.int4
          , text = parse (A.signed A.decimal)
          }
    , delimiter = ','
    , typeName = "int4"
    }


-- | Corresponds to @int8@
instance DBType Int64 where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.int8
          , text = B.int64Dec
          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
          }
    , decode =
        Decoder
          { binary = Decoders.int8
          , text = parse (A.signed A.decimal)
          }
    , delimiter = ','
    , typeName = "int8"
    }


-- | Corresponds to @float4@ and @real@
instance DBType Float where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.float4
          , text =
              \x ->
                if | x == (1 / 0)  -> "Infinity"
                   | isNaN x       -> "NaN"
                   | x == (-1 / 0) -> "-Infinity"
                   | otherwise     -> B.floatDec x
          , quote =
              \x -> Opaleye.ConstExpr
                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"
                   | isNaN x       -> Opaleye.OtherLit "'NaN'"
                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
                   | otherwise     -> Opaleye.DoubleLit $ realToFrac x
          }
    , decode =
        Decoder
          { binary = Decoders.float4
          , text = parse (floating (realToFrac <$> A.double))
          }
    , delimiter = ','
    , typeName = "float4"
    }


-- | Corresponds to @float8@ and @double precision@
instance DBType Double where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.float8
          , text =
              \x ->
                if | x == (1 / 0)  -> "Infinity"
                   | isNaN x       -> "NaN"
                   | x == (-1 / 0) -> "-Infinity"
                   | otherwise     -> B.doubleDec x
          , quote =
              \x -> Opaleye.ConstExpr
                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"
                   | isNaN x       -> Opaleye.OtherLit "'NaN'"
                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
                   | otherwise     -> Opaleye.DoubleLit x
          }
    , decode =
        Decoder
          { binary = Decoders.float8
          , text = parse (floating A.double)
          }
    , delimiter = ','
    , typeName = "float8"
    }


-- | Corresponds to @numeric@
instance DBType Scientific where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.numeric
          , text = scientificBuilder
          , quote = Opaleye.ConstExpr . Opaleye.NumericLit
          }
    , decode =
        Decoder
          { binary = Decoders.numeric
          , text = parse A.scientific
          }
    , delimiter = ','
    , typeName = "numeric"
    }


-- | Corresponds to @numeric(1000, log₁₀ n)@
instance PowerOf10 n => DBType (Fixed n) where
  typeInformation =
    mapTypeInformation realToFrac realToFrac (typeInformation @Scientific)
      { typeName =
          TypeName
            { name = "numeric"
            , modifiers = ["1000", show (resolution @n)]
            , arrayDepth = 0
            }
      }


-- | Corresponds to @timestamptz@
instance DBType UTCTime where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.timestamptz
          , text = primBounded Builder.utcTime
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit .
              formatTime defaultTimeLocale "'%FT%T%QZ'"
          }
    , decode =
        Decoder
          { binary = Decoders.timestamptz
          , text = parse Parser.utcTime
          }
    , delimiter = ','
    , typeName = "timestamptz"
    }


-- | Corresponds to @date@
instance DBType Day where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.date
          , text = primBounded Builder.day
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit .
              formatTime defaultTimeLocale "'%F'"
          }
    , decode =
        Decoder
          { binary = Decoders.date
          , text = parse Parser.day
          }
    , delimiter = ','
    , typeName = "date"
    }


-- | Corresponds to @timestamp@
instance DBType LocalTime where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.timestamp
          , text = primBounded Builder.localTime
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit .
              formatTime defaultTimeLocale "'%FT%T%Q'"
          }
    , decode =
        Decoder
          { binary = Decoders.timestamp
          , text = parse Parser.localTime
          }
    , delimiter = ','
    , typeName = "timestamp"
    }


-- | Corresponds to @time@
instance DBType TimeOfDay where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.time
          , text = primBounded Builder.timeOfDay
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit .
              formatTime defaultTimeLocale "'%T%Q'"
          }
    , decode =
        Decoder
          { binary = Decoders.time
          , text = parse Parser.timeOfDay
          }
    , delimiter = ','
    , typeName = "time"
    }


-- | Corresponds to @interval@
instance DBType CalendarDiffTime where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = toDiffTime >$< Encoders.interval
          , text = Builder.calendarDiffTime
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit .
              formatTime defaultTimeLocale "'%bmon %0Es'"
          }
    , decode =
        Decoder
          { binary = CalendarDiffTime 0 . realToFrac <$> Decoders.interval
          , text = parse Parser.calendarDiffTime
          }
    , delimiter = ','
    , typeName = "interval"
    }


-- | Corresponds to @text@
instance DBType Text where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.text
          , text = Text.encodeUtf8Builder
          , quote = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
          }
    , decode =
        Decoder
          { binary = Decoders.text
          , text = pure . Text.decodeUtf8
          }
    , delimiter = ','
    , typeName = "text"
    }


-- | Corresponds to @text@
instance DBType Lazy.Text where
  typeInformation =
    mapTypeInformation Text.fromStrict Text.toStrict typeInformation


-- | Corresponds to @citext@
instance DBType (CI Text) where
  typeInformation = mapTypeInformation CI.mk CI.original typeInformation
    { typeName = "citext"
    }


-- | Corresponds to @citext@
instance DBType (CI Lazy.Text) where
  typeInformation = mapTypeInformation CI.mk CI.original typeInformation
    { typeName = "citext"
    }


-- | Corresponds to @bytea@
instance DBType ByteString where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.bytea
          , text = Builder.bytestring
          , quote = Opaleye.ConstExpr . Opaleye.ByteStringLit
          }
    , decode =
        Decoder
          { binary = Decoders.bytea
          , text = parse Parser.bytestring
          }
    , delimiter = ','
    , typeName = "bytea"
    }


-- | Corresponds to @bytea@
instance DBType Lazy.ByteString where
  typeInformation =
    mapTypeInformation ByteString.fromStrict ByteString.toStrict
      typeInformation


-- | Corresponds to @uuid@
instance DBType UUID where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.uuid
          , text = B.byteString . UUID.toASCIIBytes
          , quote = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
          }
    , decode =
        Decoder
          { binary = Decoders.uuid
          , text = \input -> case UUID.fromASCIIBytes input of
              Just a -> pure a
              Nothing -> Left $ "uuid: bad UUID " <> show input
          }
    , delimiter = ','
    , typeName = "uuid"
    }


-- | Corresponds to @jsonb@
instance DBType Value where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.jsonb
          , text = Aeson.fromEncoding . Aeson.toEncoding
          , quote =
              Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .
              Lazy.unpack . Aeson.encodeToLazyText
          }
    , decode =
        Decoder
          { binary = Decoders.jsonb
          , text = Aeson.eitherDecodeStrict
          }
    , delimiter = ','
    , typeName = "jsonb"
    }


-- | Corresponds to @inet@
instance DBType IPRange where
  typeInformation = TypeInformation
    { encode =
        Encoder
          { binary = Encoders.inet
          , text = B.string7 . show
          , quote = Opaleye.ConstExpr . Opaleye.StringLit . show
          }
    , decode =
        Decoder
          { binary = Decoders.inet
          , text = \str -> case readMaybe $ BS8.unpack str of
              Just x -> Right x
              Nothing -> Left "Failed to parse inet"
          }
    , delimiter = ','
    , typeName = "inet"
    }


instance Sql DBType a => DBType [a] where
  typeInformation = listTypeInformation nullable typeInformation


instance Sql DBType a => DBType (NonEmpty a) where
  typeInformation = nonEmptyTypeInformation nullable typeInformation


floating :: Floating a => A.Parser a -> A.Parser a
floating p = p <|> A.signed (1.0 / 0 <$ "Infinity") <|> 0.0 / 0 <$ "NaN"


toDiffTime :: CalendarDiffTime -> DiffTime
toDiffTime (CalendarDiffTime months seconds) =
  realToFrac (months * 30 * 24 * 60 * 60) + realToFrac seconds