ENUM deriving working (proof-of-concept)

RelationalRecord/RelationalRecord.cabal

@@ -29,6 +29,7 @@ executable RelationalRecord
                     relational-query,
                     relational-schemas >= 0.1.3.2,
                     persistable-record,
+                    th-data-compat,
                     HDBC-session,
                     HDBC,
                     HDBC-postgresql,

RelationalRecord/src/Helpers/DefineEnum.hs

@@ -1,38 +1,96 @@
-{-# LANGUAGE TemplateHaskell, LambdaCase #-}
+{-# LANGUAGE TemplateHaskell, LambdaCase, ViewPatterns #-}
 
-module Helpers.DefineEnum where
+module Helpers.DefineEnum (defineEnum) where
 
 import DataSource
 
-import Language.Haskell.TH                  (Q, runIO, Name, TypeQ, Dec)
-import Language.Haskell.TH.Name.CamelCase   (varCamelcaseName)
-import Language.Haskell.TH.Lib.Extra        (reportWarning, reportError)
+import Language.Haskell.TH
+import Language.Haskell.TH.Name.CamelCase
+import Language.Haskell.TH.Compat.Data      (dataD')
 
 import Database.HDBC.Session                (withConnectionIO)
-import Database.HDBC                        (IConnection, SqlValue, safeFromSql, quickQuery')
+import Database.HDBC                        (SqlValue(..), safeFromSql, quickQuery')
 
-import Data.Either
+import Database.Record
+import Database.Record.TH                   (deriveNotNullType)
+
+import Data.ByteString.Char8                as B (pack, unpack)
+import Data.Either                          (partitionEithers)
+import Control.Arrow                        ((&&&))
 
 
--- select enumlabel from pg_type join pg_enum on (enumtypid = typelem) where typname = '_test_enum' order by enumsortorder asc;
 
 defineEnum :: String -> Q [Dec]
 defineEnum enumName =
     runIO getInfo >>= \case
         []  -> die $ "no ENUM found on DB named " ++ enumName
         vs  -> case partitionEithers [safeFromSql (head v) | v <- vs, (not . null) v] of
                 ([], vs'')  -> generateEnum enumName vs''
-                (errs, _)   -> die $ concatMap show errs
+                (errs, _)   -> die $ unlines $ map show errs
 
   where
     die err     = reportError ("defineEnum: " ++ err) >> return []
     enumName'   = '_' : enumName
     query       = "SELECT enumlabel FROM pg_type JOIN pg_enum ON (enumtypid=typelem) \
                     \WHERE typname='" ++ enumName' ++ "' ORDER BY enumsortorder ASC;"
     getInfo :: IO [[SqlValue]]
-    getInfo = withConnectionIO getDataSource $ \conn' -> quickQuery' conn' query []
+    getInfo =
+        withConnectionIO getDataSource $ \conn' -> quickQuery' conn' query []
+
+
+sqlShow :: Show a => a -> SqlValue
+sqlShow = SqlByteString . B.pack . show
 
+sqlRead :: Read a => SqlValue -> a
+sqlRead = \case
+    SqlByteString bs    -> read . B.unpack $ bs
+    SqlString s         -> read s
+    _                   -> read ""
+
+genSqlInstances :: ConName -> DecsQ
+genSqlInstances (conName -> name) =
+    [d| instance ToSql SqlValue $(conT name) where
+            recordToSql = valueRecordToSql sqlShow
+        instance FromSql SqlValue $(conT name) where
+            recordFromSql = valueRecordFromSql sqlRead|]
+{-
+genMapping :: String -> ConName -> DecsQ
+genMapping eName (conName -> name) =
+    [d| mapping :: (String, TypeQ)
+        mapping = (eName , $(varT name))|]
+-}
 
 generateEnum :: String -> [String] -> Q [Dec]
-generateEnum enumName enumVals =
-    reportWarning ('\n' : enumName ++ " ->\n" ++ unlines enumVals) >> return []
+generateEnum enumName enumVals = do
+    typeDecl    <- genEnumType name vals
+    showDecl    <- genShow name (zip vals enumVals)
+    readDecl    <- genRead name
+    sqlDecl     <- genSqlInstances name
+    persDecl    <- deriveNotNullType (conT $ conName name)
+    return      $ typeDecl : showDecl : readDecl ++ sqlDecl ++ persDecl
+  where
+    name = conCamelcaseName enumName
+    vals = map conCamelcaseName enumVals
+
+genShow :: ConName -> [(ConName, String)] -> DecQ
+genShow (conName -> name) pairs =
+  instanceD (cxt [])
+    (appT (conT ''Show) (conT name))
+    [funD (mkName "show") $ map genClause pairs]
+  where
+    genClause (k, v) = clause [(conP (conName k) [])] (normalB [|v|]) []
+
+genRead :: ConName -> DecsQ
+genRead (conName -> name) =
+    [d|instance Read $(conT name) where
+            readsPrec _ v = case lookup v dict of
+                Just res -> [(res, [])]
+                Nothing  -> []
+              where
+                dict = map (show &&& id) [minBound .. maxBound]|]
+
+genEnumType :: ConName -> [ConName] -> DecQ
+genEnumType (conName -> name) cons =
+    dataD' (cxt []) name [] cons' [''Eq, ''Enum, ''Bounded]
+  where
+    cons' = map (\n -> normalC (conName n) []) cons

RelationalRecord/src/Types/Enum.hs

@@ -4,44 +4,4 @@ module  Types.Enum where
 
 import  Helpers.DefineEnum
 
--- import  Database.HDBC.Query.TH              (makeRecordPersistableDefault)
-import  Database.Record
-import  Database.Record.TH              (deriveNotNullType)
-
-import  Database.HDBC.SqlValue
-import  Data.ByteString.Char8           (unpack)
-import  Data.Char                       (toUpper, toLower)
-
 $(defineEnum "test_enum")
-
--- TODO
--- This Haskell wrapper type is *not* type-safe, conversion might result
--- in inconsistencies or even a runtime error when the underlying DB type
--- has been changed :(
-
--- possible solution: build a custom TH action, select * from the
--- above defined table, creating the datatype below
-
--- But at least, mapping of a Postgres enum is working!
-
-
--- this definition must be verbatim to the enum type def in schema.sql !
-data TestEnum = Inactive | Active | New deriving (Show, Read, Eq)
-
-
-instance FromSql SqlValue TestEnum where
-    recordFromSql = valueRecordFromSql sqlRead
-
-instance ToSql SqlValue TestEnum where
-    recordToSql = valueRecordToSql sqlShow
-
-
-sqlRead :: Read a => SqlValue -> a
-sqlRead (SqlString (s:ss))  = read $ toUpper s : ss
-sqlRead (SqlByteString s)   = sqlRead (SqlString $ unpack s)
-sqlRead _                   = undefined
-
-sqlShow :: Show a => a -> SqlValue
-sqlShow val = let (s:ss) = show val in SqlString $ toLower s : ss
-
-$(deriveNotNullType [t| TestEnum |])

RelationalRecord/stack.yaml

@@ -45,6 +45,8 @@ packages:
       - relational-record
       - relational-schemas
 
+
+
 # The following packages have been ignored due to incompatibility with the
 # resolver compiler, dependency conflicts with other packages
 # or unsatisfied dependencies.