1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
    2 module Databrary.Model.Enum
    3   ( DBEnum
    4   , readDBEnum
    5   -- , makeDBEnum
    6   , parseJSONEnum
    7   , enumForm
    8   , pgEnumValues
    9   ) where
   10 
   11 import Control.Arrow (left)
   12 import qualified Data.Aeson.Types as JSON
   13 import qualified Data.ByteString.Char8 as BSC
   14 import qualified Data.CaseInsensitive as CI (mk)
   15 import qualified Data.Text as T
   16 import Database.PostgreSQL.Typed.Enum (PGEnum, pgEnumValues)
   17 import Text.Read (readMaybe)
   18 
   19 import Databrary.Model.Kind
   20 import Databrary.HTTP.Form (FormDatum(..))
   21 import Databrary.HTTP.Form.Deform
   22 
   23 class (PGEnum a, Kinded a) => DBEnum a
   24 
   25 readDBEnum :: forall a . DBEnum a => String -> Maybe a
   26 readDBEnum s
   27   | Just i <- readMaybe s, i >= fe minBound, i <= fe maxBound = Just (toEnum i)
   28   | [(x, _)] <- filter ((==) s . snd) pgEnumValues = Just x
   29   | [(x, _)] <- filter ((==) (CI.mk s) . CI.mk . snd) pgEnumValues = Just x
   30   | otherwise = Nothing
   31   where
   32   fe :: a -> Int
   33   fe = fromEnum
   34 
   35 parseJSONEnum :: forall a . DBEnum a => JSON.Value -> JSON.Parser a
   36 parseJSONEnum (JSON.String t) | Just e <- readDBEnum (T.unpack t) = return e
   37 parseJSONEnum (JSON.Number x) = p (round x) where
   38   p i
   39     | i < fe minBound || i > fe maxBound = fail $ kindOf (undefined :: a) ++ " out of range"
   40     | otherwise = return $ toEnum i
   41   fe :: a -> Int
   42   fe = fromEnum
   43 parseJSONEnum _ = fail $ "Invalid " ++ kindOf (undefined :: a)
   44 
   45 enumForm :: forall a m f . (Functor m, Monad m, DBEnum a) => DeformT f m a
   46 enumForm = deformParse minBound fv where
   47   fv (FormDatumBS b) = maybe e return $ readDBEnum $ BSC.unpack b
   48   fv (FormDatumJSON j) = left T.pack $ JSON.parseEither parseJSONEnum j
   49   fv _ = e
   50   e = Left $ "Invalid " `T.append` kindOf (undefined :: a)
   51 
   52 {-
   53 makeDBEnum :: String -> String -> TH.DecsQ
   54 makeDBEnum name typs = do
   55   [] <- useTDB
   56   liftM2 (++)
   57     (makePGEnum name typs (\s -> typs ++ toCamel s))
   58     [d| instance Kinded $(return typt) where
   59           kindOf _ = $(TH.litE $ TH.stringL name)
   60         instance DBEnum $(return typt)
   61         instance JSON.ToJSON $(return typt) where
   62           toJSON = JSON.toJSON . fromEnum
   63         instance JSON.FromJSON $(return typt) where
   64           parseJSON = parseJSONEnum
   65         instance Deform f $(return typt) where
   66           deform = enumForm
   67     |]
   68   where
   69   typt = TH.ConT (TH.mkName typs)
   70 -}