-- |
-- Module      :  Elm.Export.Persist.Ent
-- Copyright   :  (C) 2016-17 William Casarin
-- License     :  MIT
-- Maintainer  :  William Casarin <bill@casarin.me>
-- Stability   :  experimental
-- Portability :  non-portable

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}

module Elm.Export.Persist.Ent
    ( Ent(..)
    , EntId
    ) where

import Database.Persist
import Database.Persist.Sql
import Data.Aeson
import Elm
import Data.Proxy
import Data.Text
import Data.Scientific
import GHC.TypeLits
import GHC.Generics

import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T

-- | 'Entity' wrapper that adds `ToJSON`, `FromJSON`, and `ElmType` instances
--
-- The first type parameter 'field' is a symbol used for the key name
--
-- >>> toElmTypeSource (Proxy :: Proxy (Ent "userId" User))
-- "type alias User = { userName : String, userId : Int }"
newtype Ent (field :: Symbol) a = Ent (Entity a)
  deriving ((forall x. Ent field a -> Rep (Ent field a) x)
-> (forall x. Rep (Ent field a) x -> Ent field a)
-> Generic (Ent field a)
forall x. Rep (Ent field a) x -> Ent field a
forall x. Ent field a -> Rep (Ent field a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (field :: Symbol) a x. Rep (Ent field a) x -> Ent field a
forall (field :: Symbol) a x. Ent field a -> Rep (Ent field a) x
$cto :: forall (field :: Symbol) a x. Rep (Ent field a) x -> Ent field a
$cfrom :: forall (field :: Symbol) a x. Ent field a -> Rep (Ent field a) x
Generic)

-- | 'Ent' alias, using "id" as the key
--
-- >>> toElmTypeSource (Proxy :: Proxy (EntId User))
-- "type alias User = { userName : String, id : Int }"
type EntId a = Ent "id" a

elmIdField :: Text -> ElmValue
elmIdField :: Text -> ElmValue
elmIdField keyfield :: Text
keyfield =
  Text -> ElmValue -> ElmValue
ElmField Text
keyfield (ElmPrimitive -> ElmValue
ElmPrimitiveRef ElmPrimitive
EInt)

addIdToVals :: String -> ElmValue -> ElmValue
addIdToVals :: String -> ElmValue -> ElmValue
addIdToVals keyname :: String
keyname ev :: ElmValue
ev =
  case ElmValue
ev of
    ef :: ElmValue
ef@(ElmField{}) ->
      ElmValue -> ElmValue -> ElmValue
Values ElmValue
ef (Text -> ElmValue
elmIdField (String -> Text
T.pack String
keyname))
    Values v1 :: ElmValue
v1 rest :: ElmValue
rest -> ElmValue -> ElmValue -> ElmValue
Values ElmValue
v1 (String -> ElmValue -> ElmValue
addIdToVals String
keyname ElmValue
rest)
    _ -> ElmValue
ev


instance (KnownSymbol field, ElmType a) => ElmType (Ent field a) where
  toElmType :: Ent field a -> ElmDatatype
toElmType _ =
    case Proxy a -> ElmDatatype
forall a. ElmType a => a -> ElmDatatype
toElmType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) of
      ElmDatatype name :: Text
name (RecordConstructor x :: Text
x (Values v :: ElmValue
v vals :: ElmValue
vals)) ->
        Text -> ElmConstructor -> ElmDatatype
ElmDatatype Text
name (Text -> ElmValue -> ElmConstructor
RecordConstructor Text
x
                            (ElmValue -> ElmValue -> ElmValue
Values ElmValue
v (String -> ElmValue -> ElmValue
addIdToVals String
keyname ElmValue
vals)))
      ElmDatatype name :: Text
name (RecordConstructor x :: Text
x f :: ElmValue
f@(ElmField _ _)) ->
        Text -> ElmConstructor -> ElmDatatype
ElmDatatype Text
name (Text -> ElmValue -> ElmConstructor
RecordConstructor Text
x
                            (ElmValue -> ElmValue -> ElmValue
Values ElmValue
f (ElmValue -> ElmValue) -> ElmValue -> ElmValue
forall a b. (a -> b) -> a -> b
$ Text -> ElmValue
elmIdField (String -> Text
T.pack String
keyname)))
      x :: ElmDatatype
x -> ElmDatatype
x
    where
      keyname :: String
      keyname :: String
keyname = Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy :: Proxy field)

instance (KnownSymbol field, ToJSON a, ToJSON (Key a)) => ToJSON (Ent field a) where
  toJSON :: Ent field a -> Value
toJSON (Ent (Entity k :: Key a
k val :: a
val)) =
    case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
val of
      Object hmap :: Object
hmap -> Object -> Value
Object (Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
keyname (Key a -> Value
forall a. ToJSON a => a -> Value
toJSON Key a
k) Object
hmap)
      x :: Value
x           -> Value
x
    where
      keyname :: Text
      keyname :: Text
keyname = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy :: Proxy field)

valToKey :: ToBackendKey SqlBackend record => Value -> Maybe (Key record)
valToKey :: Value -> Maybe (Key record)
valToKey (Number n :: Scientific
n) = Int64 -> Key record
forall record.
ToBackendKey SqlBackend record =>
Int64 -> Key record
toSqlKey (Int64 -> Key record) -> Maybe Int64 -> Maybe (Key record)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scientific -> Maybe Int64
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n
valToKey _          = Maybe (Key record)
forall a. Maybe a
Nothing

instance ( ToBackendKey SqlBackend a
         , PersistEntity a
         , KnownSymbol field
         , FromJSON a) => FromJSON (Ent field a) where
  parseJSON :: Value -> Parser (Ent field a)
parseJSON obj :: Value
obj@(Object o :: Object
o) =
    let
      keyname :: String
      keyname :: String
keyname = Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy :: Proxy field)
      mkey :: Maybe Value
mkey = Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (String -> Text
T.pack String
keyname) Object
o
      keyParser :: Parser (Key a)
keyParser = do Value
key <- Parser Value
-> (Value -> Parser Value) -> Maybe Value -> Parser Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Value) -> String -> Parser Value
forall a b. (a -> b) -> a -> b
$ "Ent: no key found for field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keyname)
                            Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
mkey
                     Parser (Key a)
-> (Key a -> Parser (Key a)) -> Maybe (Key a) -> Parser (Key a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser (Key a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Ent: could not parse key as Int64")
                           Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe (Key a)
forall record.
ToBackendKey SqlBackend record =>
Value -> Maybe (Key record)
valToKey Value
key)
    in
      Entity a -> Ent field a
forall (field :: Symbol) a. Entity a -> Ent field a
Ent (Entity a -> Ent field a)
-> Parser (Entity a) -> Parser (Ent field a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Key a -> a -> Entity a
forall record. Key record -> record -> Entity record
Entity (Key a -> a -> Entity a)
-> Parser (Key a) -> Parser (a -> Entity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Key a)
keyParser
                Parser (a -> Entity a) -> Parser a -> Parser (Entity a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
obj)
  parseJSON _ = String -> Parser (Ent field a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Ent: should be an Object"