Hello community,
here is the log from the commit of package ghc-persistent for
openSUSE:Leap:15.2 checked in at 2020-03-10 17:14:31
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Leap:15.2/ghc-persistent (Old)
and /work/SRC/openSUSE:Leap:15.2/.ghc-persistent.new.26092 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent"
Tue Mar 10 17:14:31 2020 rev:14 rq:783351 version:2.10.5.2
Changes:
--------
--- /work/SRC/openSUSE:Leap:15.2/ghc-persistent/ghc-persistent.changes
2020-02-19 18:40:34.126142998 +0100
+++
/work/SRC/openSUSE:Leap:15.2/.ghc-persistent.new.26092/ghc-persistent.changes
2020-03-10 17:14:32.973437598 +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.749r9r/_old 2020-03-10 17:14:33.405437732 +0100
+++ /var/tmp/diff_new_pack.749r9r/_new 2020-03-10 17:14:33.409437733 +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"]
+ ]
+
