packages feed

persistent 0.6.1 → 0.6.2

raw patch · 5 files changed

+111/−58 lines, 5 filesdep +QuickCheckdep +randomdep −parsecdep ~bsondep ~enumeratordep ~mongoDB

Dependencies added: QuickCheck, random

Dependencies removed: parsec

Dependency ranges changed: bson, enumerator, mongoDB, time

Files

Database/Persist/GenericSql.hs view
@@ -55,7 +55,7 @@     toSinglePiece (Key (PersistInt64 i)) = toSinglePiece i     toSinglePiece k = throw $ PersistInvalidField $ "Invalid Key: " ++ show k     fromSinglePiece t =-        case Data.Text.Read.decimal t of+        case Data.Text.Read.signed Data.Text.Read.decimal t of             Right (i, "") -> Just $ Key $ PersistInt64 i             _ -> Nothing @@ -192,7 +192,7 @@         off = if offset == 0                     then ""                     else " OFFSET " ++ show offset-        cols conn = intercalate "," $ "id"+        cols conn = intercalate "," $ (unRawName $ rawTableIdName t)                    : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)         sql conn = pack $ concat             [ "SELECT "@@ -322,7 +322,7 @@      getBy uniq = do         conn <- SqlPersist ask-        let cols = intercalate "," $ "id"+        let cols = intercalate "," $ (unRawName $ rawTableIdName t)                  : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)         let sql = pack $ concat                 [ "SELECT "
Database/Persist/GenericSql/Internal.hs view
@@ -14,6 +14,7 @@     , tableColumns     , rawFieldName     , rawTableName+    , rawTableIdName     , RawName (..)     , filterClause     , filterClauseNoWhere@@ -28,7 +29,7 @@ import Control.Monad.IO.Class import Data.Pool import Database.Persist.Base-import Data.Maybe (fromJust)+import Data.Maybe (fromMaybe) import Control.Arrow import Control.Monad.IO.Control (MonadControlIO) import Control.Exception.Control (bracket)@@ -78,10 +79,15 @@     (cols, uniqs)   where     colNameMap = map (columnName &&& rawFieldName) $ entityColumns t-    uniqs = map (RawName *** map (fromJust . flip lookup colNameMap))+    uniqs = map (RawName *** map (unjustLookup colNameMap))           $ map (uniqueName &&& uniqueColumns)-          $ entityUniques t -- FIXME don't use fromJust+          $ entityUniques t     cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val++    -- Like fromJust . lookup, but gives a more useful error message+    unjustLookup m a = fromMaybe (error $ "Column not found: " ++ a)+                     $ lookup a m+     t = entityDef val     tn = rawTableName t     go (name, t', as) p =@@ -117,6 +123,11 @@ getSqlValue (_:x) = getSqlValue x getSqlValue [] = Nothing +getIdNameValue :: [String] -> Maybe String+getIdNameValue (('i':'d':'=':x):_) = Just x+getIdNameValue (_:x) = getIdNameValue x+getIdNameValue [] = Nothing+ tableColumns :: EntityDef -> [(RawName, String, [String])] tableColumns = map (\a@(ColumnDef _ y z) -> (rawFieldName a, y, z)) . entityColumns @@ -134,6 +145,12 @@         Nothing -> entityName t         Just x -> x +rawTableIdName :: EntityDef -> RawName+rawTableIdName t = RawName $+    case getIdNameValue $ entityAttribs t of+        Nothing -> "id"+        Just x -> x+ newtype RawName = RawName { unRawName :: String } -- FIXME Text     deriving (Eq, Ord) @@ -246,7 +263,8 @@ getFieldName t s = rawFieldName $ tableColumn t s  tableColumn :: EntityDef -> String -> ColumnDef-tableColumn _ "id" = ColumnDef "id" "Int64" []+tableColumn t s | s == id_ = ColumnDef id_ "Int64" []+  where id_ = unRawName $ rawTableIdName t tableColumn t s = go $ entityColumns t   where     go [] = error $ "Unknown table column: " ++ s
Database/Persist/Join/Sql.hs view
@@ -94,8 +94,9 @@ colsPlusId :: PersistEntity e => Connection -> e -> [String] colsPlusId conn e =     map (addTable conn e) $-    "id" : (map (\(x, _, _) -> escapeName conn x) cols)+    id_ : (map (\(x, _, _) -> escapeName conn x) cols)   where+    id_ = unRawName $ rawTableIdName $ entityDef e     cols = tableColumns $ entityDef e  filterName :: PersistEntity v => Filter v -> String
Database/Persist/Quasi.hs view
@@ -1,65 +1,96 @@ module Database.Persist.Quasi-    ( parse +    ( parse     ) where  import Database.Persist.Base import Data.Char import Data.Maybe (mapMaybe)-import Text.ParserCombinators.Parsec hiding (parse, token)-import qualified Text.ParserCombinators.Parsec as Parsec  -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: String -> [EntityDef]-parse = map parse' . nest . map words'-      . removeLeadingSpaces-      . map killCarriage+parse = parse'+      . removeSpaces+      . filter (not . empty)+      . map tokenize       . lines -removeLeadingSpaces :: [String] -> [String]-removeLeadingSpaces x =-    let y = filter (not . null) x-     in if all isSpace (map head y)-            then removeLeadingSpaces (map tail y)-            else y+-- | A token used by the parser.+data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.+           | Token String  -- ^ @Token tok@ is token @tok@ already unquoted. -killCarriage :: String -> String-killCarriage "" = ""-killCarriage s-    | last s == '\r' = init s-    | otherwise = s+-- | Tokenize a string.+tokenize :: String -> [Token]+tokenize [] = []+tokenize ('-':'-':_) = [] -- Comment until the end of the line.+tokenize ('"':xs) = go xs ""+    where+      go ('\"':rest) acc = Token (reverse acc) : tokenize rest+      go ('\\':y:ys) acc = go ys (y:acc)+      go (y:ys)      acc = go ys (y:acc)+      go []          acc = error $ "Unterminated quoted (\") string starting with " +++                                   show (reverse acc) ++ "."+tokenize (x:xs)+    | isSpace x = let (spaces, rest) = span isSpace xs+                  in Spaces (1 + length spaces) : tokenize rest+tokenize xs = let (token, rest) = break isSpace xs+              in Token token : tokenize rest -words' :: String -> (Bool, [String])-words' s = case Parsec.parse words'' s s of-            Left e -> error $ show e-            Right x -> x+-- | A string of tokens is empty when it has only spaces.  There+-- can't be two consecutive 'Spaces', so this takes /O(1)/ time.+empty :: [Token] -> Bool+empty []         = True+empty [Spaces _] = True+empty _          = False -words'' :: Parser (Bool, [String])-words'' = do-    s <- fmap (not . null) $ many space-    t <- many token-    eof-    return (s, takeWhile (/= "--") t)-  where-    token = do-        t <- (char '"' >> quoted) <|> unquoted-        spaces-        return t-    quoted = do-        s <- many1 $ noneOf "\""-        _ <- char '"'-        return s-    unquoted = many1 $ noneOf " \t"+-- | A line.  We don't care about spaces in the middle of the+-- line.  Also, we don't care about the ammount of indentation.+data Line = Line { lineType :: LineType+                 , tokens   :: [String] } -nest :: [(Bool, [String])] -> [(String, [String], [[String]])]-nest ((False, name:entattribs):rest) =-    let (x, y) = break (not . fst) rest-     in (name, entattribs, map snd x) : nest y-nest ((False, []):_) = error "Indented line must contain at least name"-nest ((True, _):_) = error "Blocks must begin with non-indented lines"-nest [] = []+-- | A line may be part of a header or body.+data LineType = Header | Body+                deriving (Eq) -parse' :: (String, [String], [[String]]) -> EntityDef-parse' (name, entattribs, attribs) =+-- | Remove leading spaces and remove spaces in the middle of the+-- tokens.+removeSpaces :: [[Token]] -> [Line]+removeSpaces xs = map (makeLine . subtractSpace) xs+    where+      -- | Ammount of leading spaces.+      s = minimum $ map headSpace xs++      -- | Ammount of leading space in a single token string.+      headSpace (Spaces n : _) = n+      headSpace _              = 0++      -- | Subtract the leading space.+      subtractSpace ys | s == 0 = ys+      subtractSpace (Spaces n : rest)+          | n == s    = rest+          | otherwise = Spaces (n - s) : rest+      subtractSpace _ = error "Database.Persist.Quasi: never here"++      -- | Get all tokens while ignoring spaces.+      getTokens (Token tok : rest) = tok : getTokens rest+      getTokens (Spaces _  : rest) =       getTokens rest+      getTokens []                 = []++      -- | Make a 'Line' from a @[Token]@.+      makeLine (Spaces _ : rest) = Line Body   (getTokens rest)+      makeLine rest              = Line Header (getTokens rest)++-- | Divide lines into blocks and make entity definitions.+parse' :: [Line] -> [EntityDef]+parse' (Line Header (name:entattribs) : rest) =+    let (x, y) = span ((== Body) . lineType) rest+    in mkEntityDef name entattribs (map tokens x) : parse' y+parse' ((Line Header []) : _) = error "Indented line must contain at least name."+parse' ((Line Body _)    : _) = error "Blocks must begin with non-indented lines."+parse' [] = []++-- | Construct an entity definition.+mkEntityDef :: String -> [String] -> [[String]] -> EntityDef+mkEntityDef name entattribs attribs =     EntityDef name entattribs cols uniqs derives   where     cols = mapMaybe takeCols attribs
persistent.cabal view
@@ -1,5 +1,5 @@ name:            persistent-version:         0.6.1+version:         0.6.2 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -19,7 +19,6 @@                    , time                     >= 1.1.4   && < 1.3                    , text                     >= 0.8     && < 0.12                    , containers               >= 0.2     && < 0.5-                   , parsec                   >= 2.1     && < 4                    , enumerator               >= 0.4.9   && < 0.5                    , monad-control            >= 0.2     && < 0.3                    , pool                     >= 0.1     && < 0.2@@ -51,11 +50,11 @@                    , HDBC-postgresql                    , HDBC                    -- mongoDB dependencies-                   , mongoDB       >= 1.0 && < 1.1+                   , mongoDB       == 1.1.*+                   , bson          >= 0.1.5                    , cereal                    , network                    , compact-string-fix-                   , bson                    , persistent                    , path-pieces                    , text@@ -63,6 +62,10 @@                    , monad-control                    , containers                    , bytestring+                   , enumerator+                   , time >= 1.2+                   , random == 1.*+                   , QuickCheck == 2.4.*      -- these are mutually exclusive options     -- cpp-options: -DWITH_POSTGRESQL