Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2020-03-09 14:16:36 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new.26092 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent" Mon Mar 9 14:16:36 2020 rev:18 rq:780028 version:2.10.5.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2019-12-27 13:56:14.860741776 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new.26092/ghc-persistent.changes 2020-03-09 14:16:42.578638142 +0100 @@ -1,0 +2,30 @@ +Thu Feb 27 14:18:05 UTC 2020 - [email protected] + +- Update persistent to version 2.10.5.2. + ## 2.10.5.2 + + * [#1041](https://github.com/yesodweb/persistent/pull/1041) + * Explicit foreign keys can now reference tables with custom sql name + * Add qualified names to the stock classes list. + +------------------------------------------------------------------- +Fri Feb 7 08:04:19 UTC 2020 - [email protected] + +- Update persistent to version 2.10.5.1. + ## 2.10.5.1 + + * [#1024](https://github.com/yesodweb/persistent/pull/1024) + * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. + * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi` + +------------------------------------------------------------------- +Wed Jan 29 03:01:47 UTC 2020 - [email protected] + +- Update persistent to version 2.10.5. + ## 2.10.5 + + * Add the `EntityWithPrefix` type to allow users to specify a custom prefix for raw SQL queries. [#1018](https://github.com/yesodweb/persistent/pull/1018) + * Added Acquire based API to `Database.Persist.Sql` for working with + connections/pools in monads which aren't MonadUnliftIO. [#984](https://github.com/yesodweb/persistent/pull/984) + +------------------------------------------------------------------- Old: ---- persistent-2.10.4.tar.gz New: ---- persistent-2.10.5.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.sPYvRE/_old 2020-03-09 14:16:43.642638843 +0100 +++ /var/tmp/diff_new_pack.sPYvRE/_new 2020-03-09 14:16:43.646638845 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-persistent # -# Copyright (c) 2019 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2020 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.10.4 +Version: 2.10.5.2 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT ++++++ persistent-2.10.4.tar.gz -> persistent-2.10.5.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/ChangeLog.md new/persistent-2.10.5.2/ChangeLog.md --- old/persistent-2.10.4/ChangeLog.md 2019-10-29 18:51:02.000000000 +0100 +++ new/persistent-2.10.5.2/ChangeLog.md 2020-02-15 01:07:11.000000000 +0100 @@ -1,5 +1,23 @@ # Changelog for persistent +## 2.10.5.2 + +* [#1041](https://github.com/yesodweb/persistent/pull/1041) + * Explicit foreign keys can now reference tables with custom sql name + * Add qualified names to the stock classes list. + +## 2.10.5.1 + +* [#1024](https://github.com/yesodweb/persistent/pull/1024) + * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. + * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi` + +## 2.10.5 + +* Add the `EntityWithPrefix` type to allow users to specify a custom prefix for raw SQL queries. [#1018](https://github.com/yesodweb/persistent/pull/1018) +* Added Acquire based API to `Database.Persist.Sql` for working with + connections/pools in monads which aren't MonadUnliftIO. [#984](https://github.com/yesodweb/persistent/pull/984) + ## 2.10.4 * Log exceptions when closing a connection fails. See point 1 in [yesod #1635](https://github.com/yesodweb/yesod/issues/1635#issuecomment-547300856). [#978](https://github.com/yesodweb/persistent/pull/978) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/Database/Persist/Quasi.hs new/persistent-2.10.5.2/Database/Persist/Quasi.hs --- old/persistent-2.10.4/Database/Persist/Quasi.hs 2019-10-29 08:41:44.000000000 +0100 +++ new/persistent-2.10.5.2/Database/Persist/Quasi.hs 2020-02-15 01:07:11.000000000 +0100 @@ -1,6 +1,243 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} + +{-| +This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. + +The basic structure of the syntax looks like this: + +> TableName +> fieldName FieldType +> otherField String +> nullableField Int Maybe + +You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type. + +@persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL: + +> CREATE TABLE table_name ( +> id SERIAL PRIMARY KEY, +> field_name field_type NOT NULL, +> other_field varchar NOT NULL, +> nullable_field int NULL +> ); + +Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function. + +It generates a Haskell datatype with the following form: + +@ +data TableName = TableName + { tableNameFieldName :: FieldType + , tableNameOtherField :: String + , tableNameNullableField :: Maybe Int + } +@ + +As with the SQL generated, the specifics of this are customizable. +See the @persistent-template@ package for details. + += Deriving + +You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that. +Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses. + +> User +> name String +> age Int +> deriving Eq Show +> deriving Ord + += Unique Keys + +You can define a uniqueness key on a table with the following format: + +> User +> name String +> age Int +> +> UniqueUserName name + +This will put a unique index on the @user@ table and the @name@ field. + += Setting defaults + +You can use a @default=${sql expression}@ clause to set a default for a field. +The thing following the `=` is interpreted as SQL that will be put directly into the table definition. + +@ +User + name Text + admin Bool default=false +@ + +This creates a SQL definition like this: + +> CREATE TABLE user ( +> id SERIAL PRIMARY KEY, +> name VARCHAR NOT NULL, +> admin BOOL DEFAULT=false +> ); + +A restriction here is that you still need to provide a value when performing an `insert`, because the generated Haskell type has the form: + +@ +data User = User + { userName :: Text + , userAdmin :: Bool + } +@ + +You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default. + += Custom ID column + +If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field. +This @User@ has a @Text@ ID. + +> User +> Id Text +> name Text +> age Int + +If you do this, it's a good idea to set a default for the ID. +Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts. + +@ +'insertKey' (UserKey "Hello world!") (User "Bob" 32) +@ + +If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore. +So instead just use a default expression, like this: + +@ +User + Id Text default=generate_user_id() + name Text + age Int +@ + += Custom Primary Keys + +Sometimes you don't want to have an ID column, and you want a different sort of primary key. +This is a table that stores unique email addresses, and the email is the primary key. +We store the first and second part (eg @first\@second@) separately. + +@ +Email + firstPart Text + secondPart Text + + Primary firstPart secondPart +@ + +This creates a table with the following form: + +@ +CREATE TABLE email ( + first_part varchar, + second_part varchar, + + PRIMARY KEY (first_part, second_part) +@ + +You can specify 1 or more columns in the primary key. + += Overriding SQL + +You can use a @sql=custom@ annotation to provide some customization on the entity and field. +For example, you might prefer to name a table differently than what @persistent@ will do by default. +You may also prefer to name a field differently. + +@ +User sql=big_user_table + fullName String sql=name + age Int +@ + +This will alter the generated SQL to be: + +@ +CREATE TABEL big_user_table ( + id SERIAL PRIMARY KEY, + name VARCHAR, + age INT +); +@ + += Attributes + +The QuasiQuoter allows you to provide arbitrary attributes to an entity or field. +This can be used to extend the code in ways that the library hasn't anticipated. +If you use this feature, we'd definitely appreciate hearing about it and potentially supporting your use case directly! + +@ +User !funny + field String !sad + good Dog !sogood +@ + +We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field. + +@ +userAttrs = do + let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User) + let userAttributes = 'entityAttrs' userDefinition + let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition) + print userAttributes +-- ["funny"] + print fieldAttributes +-- [["sad"],["sogood"]] +@ + += Documentation Comments + +The quasiquoter supports ordinary comments with @--@ and @#@. +Since @persistent-2.10.5.1@, it also supports documentation comments. +The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions: + +1. Only the @-- | @ form is allowed. +2. You must put a space before and after the @|@ pipe character. +3. The comment must be indented at the same level as the entity or field it documents. + +An example of the field documentation is: + +@ +-- | I am a doc comment for a User. Users are important +-- | to the application, and should be treasured. +User + -- | Users have names. Call them by names. + name String + -- | A user can be old, or young, and we care about + -- | this for some reason. + age Int +@ + +The documentation is present on the `entityComments` field on the `EntityDef` for the entity: + +@ +>>> let userDefinition = entityDef (Proxy :: Proxy User) +>>> entityComments userDefinition +"I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n" +@ + +Likewise, the field documentation is present in the `fieldComments` field on the `FieldDef` present in the `EntityDef`: + +@ +>>> let userFields = entityFields userDefinition +>>> let comments = map fieldComments userFields +>>> mapM_ putStrLn comments +"Users have names. Call them by names." +"A user can be old, or young, and we care about\nthis for some reason." +@ + +Unfortunately, we can't use this to create Haddocks for you, because <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>. +`persistent` backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions. + +-} module Database.Persist.Quasi ( parse , PersistSettings (..) @@ -9,19 +246,28 @@ , nullable #if TEST , Token (..) + , Line' (..) + , preparse , tokenize , parseFieldType + , empty + , removeSpaces + , associateLines + , skipEmpty + , LinesWithComments(..) #endif ) where import Prelude hiding (lines) +import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty(..)) import Control.Arrow ((&&&)) import Control.Monad (msum, mplus) import Data.Char import Data.List (find, foldl') import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe, maybeToList) +import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -109,21 +355,26 @@ -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] -parse ps = parseLines ps - . removeSpaces - . filter (not . empty) - . map tokenize - . T.lines +parse ps = parseLines ps . preparse + +preparse :: Text -> [Line] +preparse = + removeSpaces + . filter (not . empty) + . map tokenize + . T.lines -- | A token used by the parser. data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces. | Token Text -- ^ @Token tok@ is token @tok@ already unquoted. + | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. deriving (Show, Eq) -- | Tokenize a string. tokenize :: Text -> [Token] tokenize t | T.null t = [] + | "-- | " `T.isPrefixOf` t = [DocComment t] | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) | T.head t == '"' = quotes (T.tail t) id @@ -181,9 +432,22 @@ -- | 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 { lineIndent :: Int - , tokens :: [Text] - } +data Line' f + = Line + { lineIndent :: Int + , tokens :: f Text + } + +deriving instance Show (f Text) => Show (Line' f) +deriving instance Eq (f Text) => Eq (Line' f) + +mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g +mapLine k (Line i t) = Line i (k t) + +traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) +traverseLine k (Line i xs) = Line i <$> k xs + +type Line = Line' [] -- | Remove leading spaces and remove spaces in the middle of the -- tokens. @@ -197,6 +461,7 @@ toLine' i = Line i . mapMaybe fromToken fromToken (Token t) = Just t + fromToken (DocComment t) = Just t fromToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions. @@ -204,11 +469,87 @@ parseLines ps lines = fixForeignKeysAll $ toEnts lines where - toEnts (Line indent (name:entattribs) : rest) = - let (x, y) = span ((> indent) . lineIndent) rest - in mkEntityDef ps name entattribs x : toEnts y - toEnts (Line _ []:rest) = toEnts rest - toEnts [] = [] + toEnts :: [Line] -> [UnboundEntityDef] + toEnts = + map mk + . associateLines + . skipEmpty + mk :: LinesWithComments -> UnboundEntityDef + mk lwc = + let Line _ (name :| entAttribs) :| rest = lwcLines lwc + in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) + +isComment :: Text -> Maybe Text +isComment xs = + T.stripPrefix "-- | " xs + +data LinesWithComments = LinesWithComments + { lwcLines :: NonEmpty (Line' NonEmpty) + , lwcComments :: [Text] + } deriving (Eq, Show) + +-- TODO: drop this and use <> when 8.2 isn't supported anymore so the +-- monoid/semigroup nonsense isn't annoying +appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments +appendLwc a b = + LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) + +newLine :: Line' NonEmpty -> LinesWithComments +newLine l = LinesWithComments (pure l) [] + +firstLine :: LinesWithComments -> Line' NonEmpty +firstLine = NEL.head . lwcLines + +consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments +consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } + +consComment :: Text -> LinesWithComments -> LinesWithComments +consComment l lwc = lwc { lwcComments = l : lwcComments lwc } + +associateLines :: [Line' NonEmpty] -> [LinesWithComments] +associateLines lines = + foldr combine [] $ + foldr toLinesWithComments [] lines + where + toLinesWithComments line linesWithComments = + case linesWithComments of + [] -> + [newLine line] + (lwc : lwcs) -> + case isComment (NEL.head (tokens line)) of + Just comment + | lineIndent line == lowestIndent -> + consComment comment lwc : lwcs + _ -> + if lineIndent line <= lineIndent (firstLine lwc) + then + consLine line lwc : lwcs + else + newLine line : lwc : lwcs + + lowestIndent = minimum . fmap lineIndent $ lines + combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] + combine lwc [] = + [lwc] + combine lwc (lwc' : lwcs) = + let minIndent = minimumIndentOf lwc + otherIndent = minimumIndentOf lwc' + in + if minIndent < otherIndent then + appendLwc lwc lwc' : lwcs + else + lwc : lwc' : lwcs + + + minimumIndentOf = minimum . fmap lineIndent . lwcLines + +skipEmpty :: [Line' []] -> [Line' NonEmpty] +skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) + +setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef +setComments [] = id +setComments comments = + overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] fixForeignKeysAll unEnts = map fixForeignKeys unEnts @@ -223,24 +564,41 @@ -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = - case M.lookup (foreignRefTableHaskell fdef) entLookup of - Just pent -> case entityPrimary pent of - Just pdef -> - if length foreignFieldTexts /= length (compositeFields pdef) - then lengthError pdef - else let fds_ffs = zipWith (toForeignFields pent) - foreignFieldTexts - (compositeFields pdef) - in fdef { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - } - Nothing -> - error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent - Nothing -> - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents + let pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + in + case entityPrimary pent of + Just pdef -> + if length foreignFieldTexts /= length (compositeFields pdef) + then + lengthError pdef + else + let + fds_ffs = + zipWith (toForeignFields pent) + foreignFieldTexts + (compositeFields pdef) + dbname = + unDBName (entityDB pent) + oldDbName = + unDBName (foreignRefTableDBName fdef) + in fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + DBName dbname + , foreignConstraintNameDBName = + DBName + . T.replace oldDbName dbname . unDBName + $ foreignConstraintNameDBName fdef + } + Nothing -> + error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent where setNull :: [FieldDef] -> Bool setNull [] = error "setNull: impossible!" @@ -282,9 +640,14 @@ , unboundEntityDef :: EntityDef } +overUnboundEntityDef + :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef +overUnboundEntityDef f ubed = + ubed { unboundEntityDef = f (unboundEntityDef ubed) } lookupKeyVal :: Text -> [Text] -> Maybe Text lookupKeyVal key = lookupPrefix $ key `mappend` "=" + lookupPrefix :: Text -> [Text] -> Maybe Text lookupPrefix prefix = msum . map (T.stripPrefix prefix) @@ -297,20 +660,21 @@ mkEntityDef ps name entattribs lines = UnboundEntityDef foreigns $ EntityDef - entName - (DBName $ getDbName ps name' entattribs) + { entityHaskell = entName + , entityDB = DBName $ getDbName ps name' entattribs -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary - (setComposite primaryComposite $ fromMaybe autoIdField idField) - entattribs - cols - uniqs - [] - derives - extras - isSum - comments + , entityId = (setComposite primaryComposite $ fromMaybe autoIdField idField) + , entityAttrs = entattribs + , entityFields = cols + , entityUniques = uniqs + , entityForeigns = [] + , entityDerives = derives + , entityExtra = extras + , entitySum = isSum + , entityComments = comments + } where comments = Nothing entName = HaskellName name' @@ -332,7 +696,18 @@ derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] - cols = mapMaybe (takeColsEx ps) attribs + cols = reverse . fst . foldr k ([], []) $ reverse attribs + k x (!acc, !comments) = + case isComment =<< listToMaybe x of + Just comment -> + (acc, comment : comments) + Nothing -> + ( maybe id (:) (setFieldComments comments <$> takeColsEx ps x) acc + , [] + ) + setFieldComments [] x = x + setFieldComments xs fld = + fld { fieldComments = Just (T.unlines xs) } autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite @@ -382,9 +757,15 @@ in (ts:x, y) takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef -takeColsEx = takeCols (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) - -takeCols :: (Text -> String -> Maybe FieldDef) -> PersistSettings -> [Text] -> Maybe FieldDef +takeColsEx = + takeCols + (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) + +takeCols + :: (Text -> String -> Maybe FieldDef) + -> PersistSettings + -> [Text] + -> Maybe FieldDef takeCols _ _ ("deriving":_) = Nothing takeCols onErr ps (n':typ:rest) | not (T.null n) && isLower (T.head n) = @@ -530,13 +911,21 @@ takeForeign ps tableName _defs (refTableName:n:rest) | not (T.null n) && isLower (T.head n) = UnboundForeignDef fields $ ForeignDef - (HaskellName refTableName) - (DBName $ psToDBName ps refTableName) - (HaskellName n) - (DBName $ psToDBName ps (tableName `T.append` n)) - [] - attrs - False + { foreignRefTableHaskell = + HaskellName refTableName + , foreignRefTableDBName = + DBName $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + HaskellName n + , foreignConstraintNameDBName = + DBName $ psToDBName ps (tableName `T.append` n) + , foreignFields = + [] + , foreignAttrs = + attrs + , foreignNullable = + False + } where (fields,attrs) = break ("!" `T.isPrefixOf`) rest diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/Database/Persist/Sql/Class.hs new/persistent-2.10.5.2/Database/Persist/Sql/Class.hs --- old/persistent-2.10.4/Database/Persist/Sql/Class.hs 2019-10-29 08:41:44.000000000 +0100 +++ new/persistent-2.10.5.2/Database/Persist/Sql/Class.hs 2020-02-12 01:12:05.000000000 +0100 @@ -4,11 +4,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} + module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) + , EntityWithPrefix(..) + , unPrefix ) where +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Bits (bitSizeMaybe) import Data.ByteString (ByteString) import Data.Fixed @@ -17,7 +22,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Data.Proxy (Proxy) +import Data.Proxy (Proxy(..)) import qualified Data.Set as S import Data.Text (Text, intercalate, pack) import qualified Data.Text as T @@ -82,6 +87,88 @@ <*> fromPersistValues rowVal where nKeyFields = length $ entityKeyFields entDef + entDef = entityDef (Nothing :: Maybe record) + +-- | This newtype wrapper is useful when selecting an entity out of the +-- database and you want to provide a prefix to the table being selected. +-- +-- Consider this raw SQL query: +-- +-- > SELECT ?? +-- > FROM my_long_table_name AS mltn +-- > INNER JOIN other_table AS ot +-- > ON mltn.some_col = ot.other_col +-- > WHERE ... +-- +-- We don't want to refer to @my_long_table_name@ every time, so we create +-- an alias. If we want to select it, we have to tell the raw SQL +-- quasi-quoter that we expect the entity to be prefixed with some other +-- name. +-- +-- We can give the above query a type with this, like: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] +-- getStuff = rawSql queryText [] +-- @ +-- +-- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can +-- remove it with 'unPrefix', like this: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] +-- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] +-- @ +-- +-- The @ symbol is a "type application" and requires the @TypeApplications@ +-- language extension. +-- +-- @since 2.10.5 +newtype EntityWithPrefix (prefix :: Symbol) record + = EntityWithPrefix { unEntityWithPrefix :: Entity record } + +-- | A helper function to tell GHC what the 'EntityWithPrefix' prefix +-- should be. This allows you to use a type application to specify the +-- prefix, instead of specifying the etype on the result. +-- +-- As an example, here's code that uses this: +-- +-- @ +-- myQuery :: 'SqlPersistM' ['Entity' Person] +-- myQuery = map (unPrefix @\"p\") <$> rawSql query [] +-- where +-- query = "SELECT ?? FROM person AS p" +-- @ +-- +-- @since 2.10.5 +unPrefix :: forall prefix record. EntityWithPrefix prefix record -> Entity record +unPrefix = unEntityWithPrefix + +instance + ( PersistEntity record + , KnownSymbol prefix + , PersistEntityBackend record ~ backend + , IsPersistBackend backend + ) + => RawSql (EntityWithPrefix prefix record) where + rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) + where + sqlFields = map (((name <> ".") <>) . escape) + $ map fieldDB + -- Hacky for a composite key because + -- it selects the same field multiple times + $ entityKeyFields entDef ++ entityFields entDef + name = pack $ symbolVal (Proxy :: Proxy prefix) + entDef = entityDef (Nothing :: Maybe record) + rawSqlColCountReason a = + case fst (rawSqlCols (error "RawSql") a) of + 1 -> "one column for an 'Entity' data type without fields" + n -> show n ++ " columns for an 'Entity' data type" + rawSqlProcessRow row = case splitAt nKeyFields row of + (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey + <*> fromPersistValues rowVal + where + nKeyFields = length $ entityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) -- | @since 1.0.1 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/Database/Persist/Sql/Run.hs new/persistent-2.10.5.2/Database/Persist/Sql/Run.hs --- old/persistent-2.10.4/Database/Persist/Sql/Run.hs 2019-10-29 18:51:02.000000000 +0100 +++ new/persistent-2.10.5.2/Database/Persist/Sql/Run.hs 2020-01-28 17:35:59.000000000 +0100 @@ -6,9 +6,13 @@ import Control.Monad.IO.Unlift import qualified UnliftIO.Exception as UE import Control.Monad.Logger.CallStack +import Control.Monad.Reader (MonadReader) +import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource +import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with) import Data.IORef (readIORef) +import Data.Pool (Pool, LocalPool) import Data.Pool as P import qualified Data.Map as Map import qualified Data.Text as T @@ -19,6 +23,60 @@ import Database.Persist.Sql.Types.Internal (IsolationLevel) import Database.Persist.Sql.Raw +-- | The returned 'Acquire' gets a connection from the pool, but does __NOT__ +-- start a new transaction. Used to implement 'acquireSqlConnFromPool' and +-- 'acquireSqlConnFromPoolWithIsolation', this is useful for performing actions +-- on a connection that cannot be done within a transaction, such as VACUUM in +-- Sqlite. +-- +-- @since 2.10.5 +unsafeAcquireSqlConnFromPool + :: forall backend m + . (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +unsafeAcquireSqlConnFromPool = do + pool <- MonadReader.ask + + let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO () + freeConn (res, localPool) relType = case relType of + ReleaseException -> P.destroyResource pool localPool res + _ -> P.putResource localPool res + + return $ fst <$> mkAcquireType (P.takeResource pool) freeConn + + +-- | The returned 'Acquire' gets a connection from the pool, starts a new +-- transaction and gives access to the prepared connection. +-- +-- When the acquired connection is released the transaction is committed and +-- the connection returned to the pool. +-- +-- Upon an exception the transaction is rolled back and the connection +-- destroyed. +-- +-- This is equivalent to 'runSqlPool' but does not incur the 'MonadUnliftIO' +-- constraint, meaning it can be used within, for example, a 'Conduit' +-- pipeline. +-- +-- @since 2.10.5 +acquireSqlConnFromPool + :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +acquireSqlConnFromPool = do + connFromPool <- unsafeAcquireSqlConnFromPool + return $ connFromPool >>= acquireSqlConn + +-- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation +-- level. +-- +-- @since 2.10.5 +acquireSqlConnFromPoolWithIsolation + :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) + => IsolationLevel -> m (Acquire backend) +acquireSqlConnFromPoolWithIsolation isolation = do + connFromPool <- unsafeAcquireSqlConnFromPool + return $ connFromPool >>= acquireSqlConnWithIsolation isolation + -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- @@ -28,7 +86,7 @@ runSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a -runSqlPool r pconn = withRunInIO $ \run -> withResource pconn $ run . runSqlConn r +runSqlPool r pconn = with (acquireSqlConnFromPool pconn) $ runReaderT r -- | Like 'runSqlPool', but supports specifying an isolation level. -- @@ -36,7 +94,8 @@ runSqlPoolWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a -runSqlPoolWithIsolation r pconn i = withRunInIO $ \run -> withResource pconn $ run . (\conn -> runSqlConnWithIsolation r conn i) +runSqlPoolWithIsolation r pconn i = + with (acquireSqlConnFromPoolWithIsolation i pconn) $ runReaderT r -- | Like 'withResource', but times out the operation if resource -- allocation does not complete within the given timeout period. @@ -60,30 +119,62 @@ return ret {-# INLINABLE withResourceTimeout #-} +rawAcquireSqlConn + :: forall backend m + . (MonadReader backend m, BackendCompatible SqlBackend backend) + => Maybe IsolationLevel -> m (Acquire backend) +rawAcquireSqlConn isolation = do + conn <- MonadReader.ask + let rawConn :: SqlBackend + rawConn = projectBackend conn + + getter :: T.Text -> IO Statement + getter = getStmtConn rawConn + + beginTransaction :: IO backend + beginTransaction = conn <$ connBegin rawConn getter isolation + + finishTransaction :: backend -> ReleaseType -> IO () + finishTransaction _ relType = case relType of + ReleaseException -> connRollback rawConn getter + _ -> connCommit rawConn getter + + return $ mkAcquireType beginTransaction finishTransaction + +-- | Starts a new transaction on the connection. When the acquired connection +-- is released the transaction is committed and the connection returned to the +-- pool. +-- +-- Upon an exception the transaction is rolled back and the connection +-- destroyed. +-- +-- This is equivalent to 'runSqlConn but does not incur the 'MonadUnliftIO' +-- constraint, meaning it can be used within, for example, a 'Conduit' +-- pipeline. +-- +-- @since 2.10.5 +acquireSqlConn + :: (MonadReader backend m, BackendCompatible SqlBackend backend) + => m (Acquire backend) +acquireSqlConn = rawAcquireSqlConn Nothing + +-- | Like 'acquireSqlConn', but lets you specify an explicit isolation level. +-- +-- @since 2.10.5 +acquireSqlConnWithIsolation + :: (MonadReader backend m, BackendCompatible SqlBackend backend) + => IsolationLevel -> m (Acquire backend) +acquireSqlConnWithIsolation = rawAcquireSqlConn . Just + runSqlConn :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a -runSqlConn r conn = withRunInIO $ \runInIO -> mask $ \restore -> do - let conn' = projectBackend conn - getter = getStmtConn conn' - restore $ connBegin conn' getter Nothing - x <- onException - (restore $ runInIO $ runReaderT r conn) - (restore $ connRollback conn' getter) - restore $ connCommit conn' getter - return x +runSqlConn r conn = with (acquireSqlConn conn) $ runReaderT r -- | Like 'runSqlConn', but supports specifying an isolation level. -- -- @since 2.9.0 runSqlConnWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a -runSqlConnWithIsolation r conn isolation = withRunInIO $ \runInIO -> mask $ \restore -> do - let conn' = projectBackend conn - getter = getStmtConn conn' - restore $ connBegin conn' getter $ Just isolation - x <- onException - (restore $ runInIO $ runReaderT r conn) - (restore $ connRollback conn' getter) - restore $ connCommit conn' getter - return x +runSqlConnWithIsolation r conn isolation = + with (acquireSqlConnWithIsolation isolation conn) $ runReaderT r runSqlPersistM :: (BackendCompatible SqlBackend backend) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/Database/Persist/Sql.hs new/persistent-2.10.5.2/Database/Persist/Sql.hs --- old/persistent-2.10.4/Database/Persist/Sql.hs 2019-10-29 08:41:44.000000000 +0100 +++ new/persistent-2.10.5.2/Database/Persist/Sql.hs 2020-01-28 17:35:59.000000000 +0100 @@ -30,7 +30,7 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) import Database.Persist.Sql.Class -import Database.Persist.Sql.Run hiding (withResourceTimeout) +import Database.Persist.Sql.Run hiding (withResourceTimeout, rawAcquireSqlConn) import Database.Persist.Sql.Raw import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/persistent.cabal new/persistent-2.10.5.2/persistent.cabal --- old/persistent-2.10.4/persistent.cabal 2019-10-29 18:51:02.000000000 +0100 +++ new/persistent-2.10.5.2/persistent.cabal 2020-02-15 01:07:11.000000000 +0100 @@ -1,5 +1,5 @@ name: persistent -version: 2.10.4 +version: 2.10.5.2 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.10.4/test/main.hs new/persistent-2.10.5.2/test/main.hs --- old/persistent-2.10.4/test/main.hs 2019-10-29 08:41:44.000000000 +0100 +++ new/persistent-2.10.5.2/test/main.hs 2020-02-15 01:07:11.000000000 +0100 @@ -1,4 +1,10 @@ +{-# language RecordWildCards #-} + import Test.Hspec +import qualified Data.Text as T +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map import Database.Persist.Quasi import Database.Persist.Types @@ -74,6 +80,21 @@ , Spaces 1 , Token "baz=bin\"" ] + describe "comments" $ do + it "recognizes one line" $ do + tokenize "-- | this is a comment" `shouldBe` + [ DocComment "-- | this is a comment" + ] + it "map tokenize" $ do + map tokenize ["Foo", "-- | Hello"] + `shouldBe` + [ [Token "Foo"] + , [DocComment "-- | Hello"] + ] + it "works if comment is indented" $ do + tokenize " -- | comment" `shouldBe` + [ Spaces 2, DocComment "-- | comment" + ] describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") @@ -100,3 +121,382 @@ baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz) + + describe "preparse" $ do + it "recognizes entity" $ do + preparse "Person\n name String\n age Int" `shouldBe` + [ Line { lineIndent = 0, tokens = ["Person"] } + , Line { lineIndent = 2, tokens = ["name", "String"] } + , Line { lineIndent = 2, tokens = ["age", "Int"] } + ] + describe "recognizes comments" $ do + let text = "Foo\n x X\n-- | Hello\nBar\n name String" + linesText = T.lines text + it "T.lines" $ do + linesText + `shouldBe` + [ "Foo" + , " x X" + , "-- | Hello" + , "Bar" + , " name String" + ] + let tokens = map tokenize linesText + it "map tokenize" $ do + tokens `shouldBe` + [ [ Token "Foo" ] + , [ Spaces 2, Token "x", Spaces 1, Token "X"] + , [ DocComment "-- | Hello" ] + , [ Token "Bar" ] + , [ Spaces 1, Token "name", Spaces 1, Token "String" ] + ] + let filtered = filter (not . empty) tokens + it "filter (not . empty)" $ do + filtered `shouldBe` + [ [ Token "Foo" ] + , [ Spaces 2, Token "x", Spaces 1, Token "X"] + , [ DocComment "-- | Hello" ] + , [ Token "Bar" ] + , [ Spaces 1, Token "name", Spaces 1, Token "String" ] + ] + let spacesRemoved = removeSpaces filtered + it "removeSpaces" $ do + spacesRemoved `shouldBe` + [ Line { lineIndent = 0, tokens = ["Foo"] } + , Line { lineIndent = 2, tokens = ["x", "X"] } + , Line { lineIndent = 0, tokens = ["-- | Hello"] } + , Line { lineIndent = 0, tokens = ["Bar"] } + , Line { lineIndent = 1, tokens = ["name", "String"] } + ] + + it "preparse" $ do + preparse text `shouldBe` + [ Line { lineIndent = 0, tokens = ["Foo"] } + , Line { lineIndent = 2, tokens = ["x", "X"] } + , Line { lineIndent = 0, tokens = ["-- | Hello"] } + , Line { lineIndent = 0, tokens = ["Bar"] } + , Line { lineIndent = 1, tokens = ["name", "String"] } + ] + it "preparse indented" $ do + let t = T.unlines + [ " Foo" + , " x X" + , " -- | Comment" + , " -- hidden comment" + , " Bar" + , " name String" + ] + preparse t `shouldBe` + [ Line { lineIndent = 2, tokens = ["Foo"] } + , Line { lineIndent = 4, tokens = ["x", "X"] } + , Line { lineIndent = 2, tokens = ["-- | Comment"] } + , Line { lineIndent = 2, tokens = ["Bar"] } + , Line { lineIndent = 4, tokens = ["name", "String"] } + ] + it "preparse extra blocks" $ do + let t = T.unlines + [ "LowerCaseTable" + , " name String" + , " ExtraBlock" + , " foo bar" + , " baz" + , " ExtraBlock2" + , " something" + ] + preparse t `shouldBe` + [ Line { lineIndent = 0, tokens = ["LowerCaseTable"] } + , Line { lineIndent = 2, tokens = ["name", "String"] } + , Line { lineIndent = 2, tokens = ["ExtraBlock"] } + , Line { lineIndent = 4, tokens = ["foo", "bar"] } + , Line { lineIndent = 4, tokens = ["baz"] } + , Line { lineIndent = 2, tokens = ["ExtraBlock2"] } + , Line { lineIndent = 4, tokens = ["something"] } + ] + it "field comments" $ do + let text = T.unlines + [ "-- | Model" + , "Foo" + , " -- | Field" + , " name String" + ] + preparse text `shouldBe` + [ Line { lineIndent = 0, tokens = ["-- | Model"] } + , Line { lineIndent = 0, tokens = ["Foo"] } + , Line { lineIndent = 2, tokens = ["-- | Field"] } + , Line { lineIndent = 2, tokens = ["name", "String"] } + ] + + describe "empty" $ do + it "doesn't dispatch comments" $ do + [DocComment "-- | hello"] `shouldSatisfy` (not . empty) + it "removes spaces" $ do + [Spaces 3] `shouldSatisfy` empty + + describe "filter (not . empty)" $ do + let subject = filter (not . empty) + it "keeps comments" $ do + subject [[DocComment "-- | Hello"]] + `shouldBe` + [[DocComment "-- | Hello"]] + it "omits lines with only spaces" $ do + subject [[Spaces 3, Token "indented"], [Spaces 2]] + `shouldBe` + [[Spaces 3, Token "indented"]] + + describe "removeSpaces" $ do + it "sets indentation level for a line" $ do + removeSpaces [[Spaces 3, Token "hello", Spaces 1, Token "goodbye"]] + `shouldBe` + [ Line { lineIndent = 3, tokens = ["hello", "goodbye"] } + ] + it "does not remove comments" $ do + removeSpaces + [ [ DocComment "-- | asdf" ] + , [ Token "Foo" ] + , [ Spaces 2, Token "name", Spaces 1, Token "String" ] + ] + `shouldBe` + [ Line { lineIndent = 0, tokens = ["-- | asdf"] } + , Line { lineIndent = 0, tokens = ["Foo"] } + , Line { lineIndent = 2, tokens = ["name", "String"] } + ] + + describe "associateLines" $ do + let foo = Line { lineIndent = 0, tokens = pure "Foo" } + name'String = Line { lineIndent = 2, tokens = "name" :| ["String"] } + comment = Line { lineIndent = 0, tokens = pure "-- | comment" } + it "works" $ do + associateLines + [ comment + , foo + , name'String + ] + `shouldBe` + [ LinesWithComments + { lwcComments = ["comment"] + , lwcLines = foo :| [name'String] + } + ] + let bar = Line { lineIndent = 0, tokens = "Bar" :| ["sql", "=", "bars"] } + age'Int = Line { lineIndent = 1, tokens = "age" :| ["Int"] } + it "works when used consecutively" $ do + associateLines + [ bar + , age'Int + , comment + , foo + , name'String + ] + `shouldBe` + [ LinesWithComments + { lwcComments = [] + , lwcLines = bar :| [age'Int] + } + , LinesWithComments + { lwcComments = ["comment"] + , lwcLines = foo :| [name'String] + } + ] + it "works with textual input" $ do + let text = "Foo\n x X\n-- | Hello\nBar\n name String" + parsed = preparse text + allFull = skipEmpty parsed + associateLines allFull + `shouldBe` + [ LinesWithComments + { lwcLines = + Line {lineIndent = 0, tokens = "Foo" :| []} + :| [ Line {lineIndent = 2, tokens = "x" :| ["X"]} ] + , lwcComments = + [] + } + , LinesWithComments + { lwcLines = + Line {lineIndent = 0, tokens = "Bar" :| []} + :| [ Line {lineIndent = 1, tokens = "name" :| ["String"]}] + , lwcComments = + ["Hello"] + } + ] + it "works with extra blocks" $ do + let text = skipEmpty . preparse . T.unlines $ + [ "LowerCaseTable" + , " Id sql=my_id" + , " fullName Text" + , " ExtraBlock" + , " foo bar" + , " baz" + , " bin" + , " ExtraBlock2" + , " something" + ] + associateLines text `shouldBe` + [ LinesWithComments + { lwcLines = + Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :| + [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] } + , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] } + , Line { lineIndent = 4, tokens = pure "ExtraBlock" } + , Line { lineIndent = 8, tokens = "foo" :| ["bar"] } + , Line { lineIndent = 8, tokens = pure "baz" } + , Line { lineIndent = 8, tokens = pure "bin" } + , Line { lineIndent = 4, tokens = pure "ExtraBlock2" } + , Line { lineIndent = 8, tokens = pure "something" } + ] + , lwcComments = [] + } + ] + + it "works with extra blocks twice" $ do + let text = skipEmpty . preparse . T.unlines $ + [ "IdTable" + , " Id Day default=CURRENT_DATE" + , " name Text" + , "" + , "LowerCaseTable" + , " Id sql=my_id" + , " fullName Text" + , " ExtraBlock" + , " foo bar" + , " baz" + , " bin" + , " ExtraBlock2" + , " something" + ] + associateLines text `shouldBe` + [ LinesWithComments + { lwcLines = Line 0 (pure "IdTable") :| + [ Line 4 ("Id" :| ["Day", "default=CURRENT_DATE"]) + , Line 4 ("name" :| ["Text"]) + ] + , lwcComments = [] + } + , LinesWithComments + { lwcLines = + Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :| + [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] } + , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] } + , Line { lineIndent = 4, tokens = pure "ExtraBlock" } + , Line { lineIndent = 8, tokens = "foo" :| ["bar"] } + , Line { lineIndent = 8, tokens = pure "baz" } + , Line { lineIndent = 8, tokens = pure "bin" } + , Line { lineIndent = 4, tokens = pure "ExtraBlock2" } + , Line { lineIndent = 8, tokens = pure "something" } + ] + , lwcComments = [] + } + ] + + + it "works with field comments" $ do + let text = skipEmpty . preparse . T.unlines $ + [ "-- | Model" + , "Foo" + , " -- | Field" + , " name String" + ] + associateLines text `shouldBe` + [ LinesWithComments + { lwcLines = + Line { lineIndent = 0, tokens = "Foo" :| [] } :| + [ Line { lineIndent = 2, tokens = pure "-- | Field" } + , Line { lineIndent = 2, tokens = "name" :| ["String"] } + ] + , lwcComments = + ["Model"] + } + ] + + + + describe "parseLines" $ do + let lines = + T.unlines + [ "-- | Comment" + , "Foo" + , " -- | Field" + , " name String" + , " age Int" + , " Extra" + , " foo bar" + , " baz" + , " Extra2" + , " something" + ] + let [subject] = parse lowerCaseSettings lines + it "produces the right name" $ do + entityHaskell subject `shouldBe` HaskellName "Foo" + describe "entityFields" $ do + let fields = entityFields subject + it "has the right field names" $ do + map fieldHaskell fields `shouldMatchList` + [ HaskellName "name" + , HaskellName "age" + ] + it "has comments" $ do + map fieldComments fields `shouldBe` + [ Just "Field\n" + , Nothing + ] + it "has the comments" $ do + entityComments subject `shouldBe` + Just "Comment\n" + it "combines extrablocks" $ do + entityExtra subject `shouldBe` Map.fromList + [ ("Extra", [["foo", "bar"], ["baz"]]) + , ("Extra2", [["something"]]) + ] + describe "works with extra blocks" $ do + let [_, lowerCaseTable, idTable] = + parse lowerCaseSettings $ T.unlines + [ "" + , "IdTable" + , " Id Day default=CURRENT_DATE" + , " name Text" + , "" + , "LowerCaseTable" + , " Id sql=my_id" + , " fullName Text" + , " ExtraBlock" + , " foo bar" + , " baz" + , " bin" + , " ExtraBlock2" + , " something" + , "" + , "IdTable" + , " Id Day default=CURRENT_DATE" + , " name Text" + , "" + ] + describe "idTable" $ do + let EntityDef {..} = idTable + it "has no extra blocks" $ do + entityExtra `shouldBe` mempty + it "has the right name" $ do + entityHaskell `shouldBe` HaskellName "IdTable" + it "has the right fields" $ do + map fieldHaskell entityFields `shouldMatchList` + [ HaskellName "name" + ] + describe "lowerCaseTable" $ do + let EntityDef {..} = lowerCaseTable + it "has the right name" $ do + entityHaskell `shouldBe` HaskellName "LowerCaseTable" + it "has the right fields" $ do + map fieldHaskell entityFields `shouldMatchList` + [ HaskellName "fullName" + ] + it "has ExtraBlock" $ do + Map.lookup "ExtraBlock" entityExtra + `shouldBe` Just + [ ["foo", "bar"] + , ["baz"] + , ["bin"] + ] + it "has ExtraBlock2" $ do + Map.lookup "ExtraBlock2" entityExtra + `shouldBe` Just + [ ["something"] + ] +
