Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added the rename rules

  • Loading branch information...
commit c3dd94fb82ea04fe62dfc594048cd82bd40d2700 1 parent f25451e
@snoyberg snoyberg authored
View
165 persistent-postgresql/Database/Persist/Postgresql.hs
@@ -15,6 +15,7 @@ import Database.Persist hiding (Update)
import Database.Persist.Base hiding (Add, Update)
import Database.Persist.GenericSql hiding (Key(..))
import Database.Persist.GenericSql.Internal
+import Database.Persist.EntityDef
import qualified Database.HDBC as H
import qualified Database.HDBC.PostgreSQL as H
@@ -81,12 +82,12 @@ prepare' conn sql = do
, withStmt = withStmt' stmt
}
-insertSql' :: RawName -> [RawName] -> Either Text (Text, Text)
+insertSql' :: DBName -> [DBName] -> Either Text (Text, Text)
insertSql' t cols = Left $ pack $ concat
[ "INSERT INTO "
- , escape t
+ , T.unpack $ escape t
, "("
- , intercalate "," $ map escape cols
+ , intercalate "," $ map (T.unpack . escape) cols
, ") VALUES("
, intercalate "," (map (const "?") cols)
, ") RETURNING id"
@@ -141,22 +142,25 @@ pFromSql (H.SqlLocalTime d) = PersistUTCTime $ localTimeToUTC utc d
pFromSql x = PersistText $ pack $ H.fromSql x -- FIXME
migrate' :: PersistEntity val
- => (Text -> IO Statement)
+ => [EntityDef]
+ -> (Text -> IO Statement)
-> val
-> IO (Either [Text] [(Bool, Text)])
-migrate' getter val = do
- let name = rawTableName $ entityDef val
- old <- getColumns getter name
+migrate' allDefs getter val = do
+ let name = entityDB $ entityDef val
+ old <- getColumns getter $ entityDef val
case partitionEithers old of
([], old'') -> do
let old' = partitionEithers old''
- let new = mkColumns val
+ let new = second (map udToPair) $ mkColumns allDefs val
if null old
then do
let addTable = AddTable $ concat
[ "CREATE TABLE "
- , escape name
- , "(id SERIAL PRIMARY KEY UNIQUE"
+ , T.unpack $ escape name
+ , "("
+ , T.unpack $ escape $ entityID $ entityDef val
+ , " SERIAL PRIMARY KEY UNIQUE"
, concatMap (\x -> ',' : showColumn x) $ fst new
, ")"
]
@@ -172,25 +176,30 @@ migrate' getter val = do
data AlterColumn = Type SqlType | IsNull | NotNull | Add Column | Drop
| Default String | NoDefault | Update String
- | AddReference RawName | DropReference RawName
-type AlterColumn' = (RawName, AlterColumn)
+ | AddReference DBName | DropReference DBName
+type AlterColumn' = (DBName, AlterColumn)
-data AlterTable = AddUniqueConstraint RawName [RawName]
- | DropConstraint RawName
+data AlterTable = AddUniqueConstraint DBName [DBName]
+ | DropConstraint DBName
data AlterDB = AddTable String
- | AlterColumn RawName AlterColumn'
- | AlterTable RawName AlterTable
+ | AlterColumn DBName AlterColumn'
+ | AlterTable DBName AlterTable
-- | Returns all of the columns in the given table currently in the database.
getColumns :: (Text -> IO Statement)
- -> RawName -> IO [Either Text (Either Column UniqueDef')]
-getColumns getter name = do
- stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> 'id'"
- cs <- withStmt stmt [PersistText $ pack $ unRawName name] helper
+ -> EntityDef
+ -> IO [Either Text (Either Column (DBName, [DBName]))]
+getColumns getter def = do
+ stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> ?"
+ let vals =
+ [ PersistText $ unDBName $ entityDB def
+ , PersistText $ unDBName $ entityID def
+ ]
+ cs <- withStmt stmt vals helper
stmt' <- getter
- "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> 'id' ORDER BY constraint_name, column_name"
- us <- withStmt stmt' [PersistText $ pack $ unRawName name] helperU
+ "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> ? ORDER BY constraint_name, column_name"
+ us <- withStmt stmt' vals helperU
return $ cs ++ us
where
getAll pop front = do
@@ -202,22 +211,23 @@ getColumns getter name = do
Just _ -> getAll pop front -- FIXME error message?
helperU pop = do
rows <- getAll pop id
- return $ map (Right . Right . (RawName . fst . head &&& map (RawName . snd)))
- $ groupBy ((==) `on` fst) rows
+ return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))
+ $ groupBy ((==) `on` fst)
+ $ map (T.pack *** T.pack) rows
helper pop = do
x <- pop
case x of
Nothing -> return []
Just x' -> do
- col <- getColumn getter name x'
+ col <- getColumn getter (entityDB def) x'
let col' = case col of
Left e -> Left e
Right c -> Right $ Left c
cols <- helper pop
return $ col' : cols
-getAlters :: ([Column], [UniqueDef'])
- -> ([Column], [UniqueDef'])
+getAlters :: ([Column], [(DBName, [DBName])])
+ -> ([Column], [(DBName, [DBName])])
-> ([AlterColumn'], [AlterTable])
getAlters (c1, u1) (c2, u2) =
(getAltersC c1 c2, getAltersU u1 u2)
@@ -226,6 +236,10 @@ getAlters (c1, u1) (c2, u2) =
getAltersC (new:news) old =
let (alters, old') = findAlters new old
in alters ++ getAltersC news old'
+
+ getAltersU :: [(DBName, [DBName])]
+ -> [(DBName, [DBName])]
+ -> [AlterTable]
getAltersU [] old = map (DropConstraint . fst) old
getAltersU ((name, cols):news) old =
case lookup name old of
@@ -239,7 +253,7 @@ getAlters (c1, u1) (c2, u2) =
: getAltersU news old'
getColumn :: (Text -> IO Statement)
- -> RawName -> [PersistValue]
+ -> DBName -> [PersistValue]
-> IO (Either Text Column)
getColumn getter tname
[PersistByteString x, PersistByteString y,
@@ -250,10 +264,10 @@ getColumn getter tname
case getType $ bsToChars z of
Left s -> return $ Left s
Right t -> do
- let cname = RawName $ bsToChars x
+ let cname = DBName $ T.pack $ bsToChars x
ref <- getRef cname
return $ Right $ Column cname (bsToChars y == "YES")
- t d'' ref
+ t (fmap T.pack d'') ref
where
getRef cname = do
let sql = pack $ concat
@@ -266,11 +280,11 @@ getColumn getter tname
let ref = refName tname cname
stmt <- getter sql
withStmt stmt
- [ PersistText $ pack $ unRawName tname
- , PersistText $ pack $ unRawName ref
+ [ PersistText $ unDBName tname
+ , PersistText $ unDBName ref
] $ \pop -> do
Just [PersistInt64 i] <- pop
- return $ if i == 0 then Nothing else Just (RawName "", ref)
+ return $ if i == 0 then Nothing else Just (DBName "", ref)
d' = case d of
PersistNull -> Right Nothing
PersistByteString a -> Right $ Just $ bsToChars a
@@ -306,7 +320,7 @@ findAlters col@(Column name isNull type_ def ref) cols =
(False, True) ->
let up = case def of
Nothing -> id
- Just s -> (:) (name, Update s)
+ Just s -> (:) (name, Update $ T.unpack s)
in up [(name, NotNull)]
_ -> []
modType = if type_ == type_' then [] else [(name, Type type_)]
@@ -315,23 +329,23 @@ findAlters col@(Column name isNull type_ def ref) cols =
then []
else case def of
Nothing -> [(name, NoDefault)]
- Just s -> [(name, Default s)]
+ Just s -> [(name, Default $ T.unpack s)]
in (modRef ++ modDef ++ modNull ++ modType,
filter (\c -> cName c /= name) cols)
showColumn :: Column -> String
showColumn (Column n nu t def ref) = concat
- [ escape n
+ [ T.unpack $ escape n
, " "
, showSqlType t
, " "
, if nu then "NULL" else "NOT NULL"
, case def of
Nothing -> ""
- Just s -> " DEFAULT " ++ s
+ Just s -> " DEFAULT " ++ T.unpack s
, case ref of
Nothing -> ""
- Just (s, _) -> " REFERENCES " ++ escape s
+ Just (s, _) -> " REFERENCES " ++ T.unpack (escape s)
]
showSqlType :: SqlType -> String
@@ -354,106 +368,110 @@ showAlterDb (AlterColumn t (c, ac)) =
isUnsafe _ = False
showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at)
-showAlterTable :: RawName -> AlterTable -> String
+showAlterTable :: DBName -> AlterTable -> String
showAlterTable table (AddUniqueConstraint cname cols) = concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ADD CONSTRAINT "
- , escape cname
+ , T.unpack $ escape cname
, " UNIQUE("
- , intercalate "," $ map escape cols
+ , intercalate "," $ map (T.unpack . escape) cols
, ")"
]
showAlterTable table (DropConstraint cname) = concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " DROP CONSTRAINT "
- , escape cname
+ , T.unpack $ escape cname
]
-showAlter :: RawName -> AlterColumn' -> String
+showAlter :: DBName -> AlterColumn' -> String
showAlter table (n, Type t) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ALTER COLUMN "
- , escape n
+ , T.unpack $ escape n
, " TYPE "
, showSqlType t
]
showAlter table (n, IsNull) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ALTER COLUMN "
- , escape n
+ , T.unpack $ escape n
, " DROP NOT NULL"
]
showAlter table (n, NotNull) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ALTER COLUMN "
- , escape n
+ , T.unpack $ escape n
, " SET NOT NULL"
]
showAlter table (_, Add col) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ADD COLUMN "
, showColumn col
]
showAlter table (n, Drop) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " DROP COLUMN "
- , escape n
+ , T.unpack $ escape n
]
showAlter table (n, Default s) =
concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ALTER COLUMN "
- , escape n
+ , T.unpack $ escape n
, " SET DEFAULT "
, s
]
showAlter table (n, NoDefault) = concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ALTER COLUMN "
- , escape n
+ , T.unpack $ escape n
, " DROP DEFAULT"
]
showAlter table (n, Update s) = concat
[ "UPDATE "
- , escape table
+ , T.unpack $ escape table
, " SET "
- , escape n
+ , T.unpack $ escape n
, "="
, s
, " WHERE "
- , escape n
+ , T.unpack $ escape n
, " IS NULL"
]
showAlter table (n, AddReference t2) = concat
[ "ALTER TABLE "
- , escape table
+ , T.unpack $ escape table
, " ADD CONSTRAINT "
- , escape $ refName table n
+ , T.unpack $ escape $ refName table n
, " FOREIGN KEY("
- , escape n
+ , T.unpack $ escape n
, ") REFERENCES "
- , escape t2
+ , T.unpack $ escape t2
+ ]
+showAlter table (_, DropReference cname) = concat
+ [ "ALTER TABLE "
+ , T.unpack (escape table)
+ , " DROP CONSTRAINT "
+ , T.unpack $ escape cname
]
-showAlter table (_, DropReference cname) =
- "ALTER TABLE " ++ escape table ++ " DROP CONSTRAINT " ++ escape cname
-escape :: RawName -> String
-escape (RawName s) =
- '"' : go s ++ "\""
+escape :: DBName -> Text
+escape (DBName s) =
+ T.pack $ '"' : go (T.unpack s) ++ "\""
where
go "" = ""
go ('"':xs) = "\"\"" ++ go xs
@@ -498,3 +516,10 @@ safeRead name t = case reads s of
[] -> MLeft $ concat ["Invalid value for ", name, ": ", s]
where
s = T.unpack t
+
+refName :: DBName -> DBName -> DBName
+refName (DBName table) (DBName column) =
+ DBName $ T.concat [table, "_", column, "_fkey"]
+
+udToPair :: UniqueDef -> (DBName, [DBName])
+udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)
View
18 persistent-sqlite/Database/Persist/Sqlite.hs
@@ -135,7 +135,7 @@ migrate' :: PersistEntity val
-> IO (Either [Text] [(Bool, Text)])
migrate' allDefs getter val = do
let (cols, uniqs) = mkColumns allDefs val
- let newSql = mkCreateTable False table (cols, uniqs)
+ let newSql = mkCreateTable False def (cols, uniqs)
stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?"
oldSql' <- withStmt stmt [PersistText $ unDBName table] go
case oldSql' of
@@ -167,7 +167,7 @@ getCopyTable allDefs getter val = do
let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ?
let newCols = map cName cols
let common = filter (`elem` oldCols) newCols
- let id_ = DBName "id" -- FIXME rawTableIdName $ entityDef val
+ let id_ = entityID $ entityDef val
return [ (False, tmpSql)
, (False, copyToTemp $ id_ : common)
, (common /= oldCols, pack dropOld)
@@ -188,8 +188,8 @@ getCopyTable allDefs getter val = do
table = entityDB def
tableTmp = DBName $ unDBName table `T.append` "_backup"
(cols, uniqs) = mkColumns allDefs val
- newSql = mkCreateTable False table (cols, uniqs)
- tmpSql = mkCreateTable True tableTmp (cols, uniqs)
+ newSql = mkCreateTable False def (cols, uniqs)
+ tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols, uniqs)
dropTmp = "DROP TABLE " ++ escape' tableTmp
dropOld = "DROP TABLE " ++ escape' table
copyToTemp common = pack $ concat
@@ -213,13 +213,15 @@ getCopyTable allDefs getter val = do
escape' = T.unpack . escape
-mkCreateTable :: Bool -> DBName -> ([Column], [UniqueDef]) -> Sql
-mkCreateTable isTemp table (cols, uniqs) = pack $ concat
+mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef]) -> Sql
+mkCreateTable isTemp entity (cols, uniqs) = pack $ concat
[ "CREATE"
, if isTemp then " TEMP" else ""
, " TABLE "
- , T.unpack $ escape table
- , "(id INTEGER PRIMARY KEY"
+ , T.unpack $ escape $ entityDB entity
+ , "("
+ , T.unpack $ escape $ entityID entity
+ , " INTEGER PRIMARY KEY"
, concatMap sqlColumn cols
, concatMap sqlUnique uniqs
, ")"
View
12 persistent-template/Database/Persist/TH.hs
@@ -8,7 +8,8 @@ module Database.Persist.TH
( mkPersist
, share
, persist
- , persistSql
+ , persistUpperCase
+ , persistLowerCase
, persistFile
, share2
, mkSave
@@ -53,8 +54,11 @@ persist ps = QuasiQuoter
{ quoteExp = lift . parse ps . pack
}
-persistSql :: QuasiQuoter
-persistSql = persist sqlSettings
+persistUpperCase :: QuasiQuoter
+persistUpperCase = persist upperCaseSettings
+
+persistLowerCase :: QuasiQuoter
+persistLowerCase = persist lowerCaseSettings
persistFile :: PersistSettings -> FilePath -> Q Exp
persistFile ps fp = do
@@ -281,7 +285,7 @@ mkEntity mps t = do
else id) idname
fields <- mapM (mkField t) $ FieldDef
(HaskellName "Id")
- (DBName "Id")
+ (entityID t)
(FieldType $ unHaskellName (entityHaskell t) ++ "Id") []
: entityFields t
toFieldNames <- mkToFieldNames $ entityUniques t
View
4 persistent-test/PersistentTest.hs
@@ -59,7 +59,7 @@ import Database.Persist.Postgresql
#endif
-import Database.Persist.TH (mkPersist, mkMigrate, derivePersistField, share, sqlMkSettings, persistSql, mkDeleteCascade)
+import Database.Persist.TH (mkPersist, mkMigrate, derivePersistField, share, sqlMkSettings, persistUpperCase, mkDeleteCascade)
import Control.Monad.IO.Class
import Control.Monad (unless)
@@ -107,7 +107,7 @@ derivePersistField "PetType"
#if WITH_MONGODB
mkPersist MkPersistSettings { mpsBackend = ConT ''Action } [persistSQL|
#else
-share [mkPersist sqlMkSettings, mkMigrate "testMigrate", mkDeleteCascade] [persistSql|
+share [mkPersist sqlMkSettings, mkMigrate "testMigrate", mkDeleteCascade] [persistUpperCase|
#endif
-- Dedented comment
-- Header-level comment
View
54 persistent-test/RenameTest.hs
@@ -1,9 +1,59 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
module RenameTest
( renameSpecs
) where
import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Test.HUnit hiding (Test)
+import Database.Persist.Sqlite
+import Database.Persist.TH
+import Database.Persist.GenericSql.Raw
+#if WITH_POSTGRESQL
+import Database.Persist.Postgresql
+#endif
+#if MIN_VERSION_monad_control(0, 3, 0)
+import qualified Control.Monad.Trans.Control
+#else
+import qualified Control.Monad.IO.Control
+#endif
-renameSpecs :: Specs
-renameSpecs = do
+-- Test lower case names
+share [mkPersist sqlMkSettings, mkMigrate "lowerCase"] [persistLowerCase|
+LowerCaseTable id=my_id
+ fullName String
+RefTable
+ someVal Int sql=something_else
+ lct LowerCaseTableId
+ UniqueRefTable someVal
+|]
+
+runConn ::
+#if MIN_VERSION_monad_control(0, 3, 0)
+ (Control.Monad.Trans.Control.MonadBaseControl IO m, MonadIO m)
+#else
+ Control.Monad.IO.Control.MonadControlIO m
+#endif
+ => SqlPersist m t -> m ()
+runConn f = do
+ _ <- withSqlitePool ":memory:" 1 $ runSqlPool f
+#if WITH_POSTGRESQL
+ _ <- withPostgresqlPool "user=test password=test host=localhost port=5432 dbname=test" 1 $ runSqlPool f
+#endif
return ()
+
+renameSpecs :: Specs
+renameSpecs = describe "rename specs" $ do
+ it "handles lower casing" $ asIO $ do
+ runConn $ do
+ runMigrationSilent lowerCase
+ withStmt "SELECT full_name from lower_case_table WHERE my_id=5" [] $ const $ return ()
+ withStmt "SELECT something_else from ref_table WHERE id=4" [] $ const $ return ()
+
+asIO :: IO a -> IO a
+asIO = id
View
3  persistent-test/persistent-test.cabal
@@ -35,6 +35,7 @@ library
Database.Sqlite
Database.Persist
Database.Persist.Quasi
+ Database.Persist.Postgresql
build-depends: base >= 4 && < 5
, HUnit
, hspec >= 0.8 && < 0.10
@@ -53,7 +54,7 @@ library
, path-pieces
, text
, transformers
- , monad-control == 0.3.*
+ , monad-control
, containers
, bytestring
, enumerator
View
92 persistent/Database/Persist/Quasi.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Database.Persist.Quasi
( parse
- , PersistSettings (..) -- FIXME
- , sqlSettings
+ , PersistSettings (..)
+ , upperCaseSettings
+ , lowerCaseSettings
) where
import Database.Persist.Base
@@ -13,14 +14,27 @@ import Data.Text (Text)
import qualified Data.Text as T
import Control.Arrow ((&&&))
-data PersistSettings = PersistSettings -- FIXME
+data PersistSettings = PersistSettings
+ { psToDBName :: Text -> Text
+ }
-sqlSettings :: PersistSettings
-sqlSettings = PersistSettings
+upperCaseSettings :: PersistSettings
+upperCaseSettings = PersistSettings
+ { psToDBName = id
+ }
+
+lowerCaseSettings :: PersistSettings
+lowerCaseSettings = PersistSettings
+ { psToDBName =
+ let go c
+ | isUpper c = T.pack ['_', toLower c]
+ | otherwise = T.singleton c
+ in T.dropWhile (== '_') . T.concatMap go
+ }
-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse :: PersistSettings -> Text -> [EntityDef]
-parse ps = parse'
+parse ps = parse' ps
. removeSpaces
. filter (not . empty)
. map tokenize
@@ -99,54 +113,74 @@ removeSpaces xs = map (makeLine . subtractSpace) xs
makeLine rest = Line Header (getTokens rest)
-- | Divide lines into blocks and make entity definitions.
-parse' :: [Line] -> [EntityDef]
-parse' (Line Header (name:entattribs) : rest) =
+parse' :: PersistSettings -> [Line] -> [EntityDef]
+parse' ps (Line Header (name:entattribs) : rest) =
let (x, y) = span ((== Body) . lineType) rest
- in mkEntityDef name entattribs (map tokens x) : parse' y
-parse' ((Line Header []) : _) =
+ in mkEntityDef ps name entattribs (map tokens x) : parse' ps y
+parse' _ ((Line Header []) : _) =
error "Indented line must contain at least name."
-parse' ((Line Body _) : _) =
+parse' _ ((Line Body _) : _) =
error "Blocks must begin with non-indented lines."
-parse' [] = []
+parse' _ [] = []
type RawLine = [Text]
-- | Construct an entity definition.
-mkEntityDef :: Text -- ^ name
+mkEntityDef :: PersistSettings
+ -> Text -- ^ name
-> [Attr] -- ^ entity attributes
-> [RawLine] -- ^ indented lines
-> EntityDef
-mkEntityDef name entattribs attribs =
+mkEntityDef ps name entattribs attribs =
EntityDef
(HaskellName name)
- (DBName name) -- FIXME
- (DBName "id") -- FIXME
+ (DBName $ psToDBName ps name)
+ (DBName $ idName entattribs)
entattribs cols uniqs derives
where
- cols = mapMaybe takeCols attribs
- uniqs = mapMaybe takeUniqs attribs
+ idName [] = "id"
+ idName (t:ts) =
+ case T.stripPrefix "id=" t of
+ Nothing -> idName ts
+ Just s -> s
+ cols = mapMaybe (takeCols ps) attribs
+ uniqs = mapMaybe (takeUniqs ps cols) attribs
derives = case mapMaybe takeDerives attribs of
[] -> ["Show", "Read", "Eq"]
x -> concat x
-takeCols :: [Text] -> Maybe FieldDef
-takeCols ("deriving":_) = Nothing
-takeCols (n:ty:rest)
+takeCols :: PersistSettings -> [Text] -> Maybe FieldDef
+takeCols _ ("deriving":_) = Nothing
+takeCols ps (n:ty:rest)
| not (T.null n) && isLower (T.head n) = Just $ FieldDef
(HaskellName n)
- (DBName n) -- FIXME
+ (DBName $ db rest)
(FieldType ty)
rest
-takeCols _ = Nothing
-
-takeUniqs :: [Text] -> Maybe UniqueDef
-takeUniqs (n:rest)
+ where
+ db [] = psToDBName ps n
+ db (a:as) =
+ case T.stripPrefix "sql=" a of
+ Nothing -> db as
+ Just s -> s
+takeCols _ _ = Nothing
+
+takeUniqs :: PersistSettings
+ -> [FieldDef]
+ -> [Text]
+ -> Maybe UniqueDef
+takeUniqs ps defs (n:rest)
| not (T.null n) && isUpper (T.head n)
= Just $ UniqueDef
(HaskellName n)
- (DBName n {- FIXME -})
- (map (HaskellName &&& DBName) rest) -- FIXME
-takeUniqs _ = Nothing
+ (DBName $ psToDBName ps n)
+ (map (HaskellName &&& getDBName defs) rest)
+ where
+ getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t
+ getDBName (d:ds) t
+ | fieldHaskell d == HaskellName t = fieldDB d
+ | otherwise = getDBName ds t
+takeUniqs _ _ _ = Nothing
takeDerives :: [Text] -> Maybe [Text]
takeDerives ("deriving":rest) = Just rest
Please sign in to comment.
Something went wrong with that request. Please try again.