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 -}