Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Refactor entity constraint parsing in Quasi module #1315

Merged
2 changes: 2 additions & 0 deletions persistent/ChangeLog.md
Original file line number Diff line number Diff line change
@@ -22,6 +22,8 @@

## 2.13.2.0

* [#1315](https://github.com/yesodweb/persistent/pull/1315)
* Refactor entity constraint parsing in Quasi module
* [#1314](https://github.com/yesodweb/persistent/pull/1314)
* Fix typos and minor documentation issues in Database.Persist and
Database.Persist.Quasi.
148 changes: 99 additions & 49 deletions persistent/Database/Persist/Quasi/Internal.hs
Original file line number Diff line number Diff line change
@@ -26,7 +26,7 @@ module Database.Persist.Quasi.Internal
, parseFieldType
, associateLines
, LinesWithComments(..)
, splitExtras
, parseEntityFields
, takeColsEx
-- * UnboundEntityDef
, UnboundEntityDef(..)
@@ -52,13 +52,12 @@ module Database.Persist.Quasi.Internal
import Prelude hiding (lines)

import Control.Applicative (Alternative((<|>)))
import Control.Monad (mplus)
import Data.Char (isLower, isSpace, isUpper, toLower)
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
@@ -311,7 +310,7 @@ toParsedEntityDef lwc = ParsedEntityDef
_ -> (False, EntityNameHS entityName)

(attribs, extras) =
splitExtras fieldLines
parseEntityFields fieldLines

isDocComment :: Token -> Maybe Text
isDocComment tok =
@@ -636,7 +635,7 @@ mkUnboundEntityDef
mkUnboundEntityDef ps parsedEntDef =
UnboundEntityDef
{ unboundForeignDefs =
foreigns
entityConstraintDefsForeignsList entityConstraintDefs
, unboundPrimarySpec =
case (idField, primaryComposite) of
(Just {}, Just {}) ->
@@ -667,7 +666,7 @@ mkUnboundEntityDef ps parsedEntDef =
parsedEntityDefEntityAttributes parsedEntDef
, entityFields =
[]
, entityUniques = uniqs
, entityUniques = entityConstraintDefsUniquesList entityConstraintDefs
, entityForeigns = []
, entityDerives = concat $ mapMaybe takeDerives textAttribs
, entityExtra = parsedEntityDefExtras parsedEntDef
@@ -689,17 +688,20 @@ mkUnboundEntityDef ps parsedEntDef =
textAttribs =
fmap tokenText <$> attribs

(idField, primaryComposite, uniqs, foreigns) =
foldl'
(\(mid, mp, us, fs) attr ->
let
(i, p, u, f) = takeConstraint ps entNameHS cols attr
squish xs m = xs `mappend` maybeToList m
in
(just1 mid i, just1 mp p, squish us u, squish fs f)
)
(Nothing, Nothing, [],[])
textAttribs
entityConstraintDefs =
foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs

idField =
case entityConstraintDefsIdField entityConstraintDefs of
SetMoreThanOnce -> error "expected only one Id declaration per entity"
SetOnce a -> Just a
NotSet -> Nothing

primaryComposite =
case entityConstraintDefsPrimaryComposite entityConstraintDefs of
SetMoreThanOnce -> error "expected only one Primary declaration per entity"
SetOnce a -> Just a
NotSet -> Nothing

cols :: [UnboundFieldDef]
cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs
@@ -801,11 +803,6 @@ setFieldComments xs fld =
[] -> fld
_ -> fld { unboundFieldComments = Just (T.unlines xs) }

just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
just1 (Just x) (Just y) = error $ "expected only one of: "
`mappend` show x `mappend` " " `mappend` show y
just1 x y = x `mplus` y

mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField ps =
mkAutoIdField' (FieldNameDB $ psIdName ps)
@@ -833,24 +830,21 @@ mkAutoIdField' dbName entName idSqlType =
keyConName :: EntityNameHS -> Text
keyConName entName = unEntityNameHS entName `mappend` "Id"

splitExtras
parseEntityFields
:: [Line]
-> ( [[Token]]
, M.Map Text [ExtraLine]
)
splitExtras lns =
-> ([[Token]], M.Map Text [ExtraLine])
parseEntityFields lns =
case lns of
[] -> ([], M.empty)
(line : rest) ->
case NEL.toList (tokens line) of
[Token name]
| isCapitalizedText name ->
let indent = lineIndent line
(children, rest') = span ((> indent) . lineIndent) rest
(x, y) = splitExtras rest'
let (children, rest') = span ((> lineIndent line) . lineIndent) rest
(x, y) = parseEntityFields rest'
in (x, M.insert name (NEL.toList . lineText <$> children) y)
ts ->
let (x, y) = splitExtras rest
let (x, y) = parseEntityFields rest
in (ts:x, y)

isCapitalizedText :: Text -> Bool
@@ -928,28 +922,84 @@ getSqlNameOr def =
_ ->
Nothing

data SetOnceAtMost a
= NotSet
| SetOnce a
| SetMoreThanOnce

instance Semigroup (SetOnceAtMost a) where
a <> b =
case (a, b) of
(_, NotSet) -> a
(NotSet, _) -> b
(SetOnce _, SetOnce _) -> SetMoreThanOnce
_ -> a

instance Monoid (SetOnceAtMost a) where
mempty =
NotSet

data EntityConstraintDefs = EntityConstraintDefs
{ entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
, entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
, entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
, entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
}

instance Semigroup EntityConstraintDefs where
a <> b =
EntityConstraintDefs
{ entityConstraintDefsIdField = entityConstraintDefsIdField a <> entityConstraintDefsIdField b
, entityConstraintDefsPrimaryComposite = entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b
, entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b
, entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b
}

instance Monoid EntityConstraintDefs where
mempty =
EntityConstraintDefs mempty mempty Nothing Nothing

entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques

entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList = foldMap NEL.toList . entityConstraintDefsForeigns

takeConstraint
:: PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> [Text]
-> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
takeConstraint ps entityName defs (n:rest) | isCapitalizedText n = takeConstraint'
where
takeConstraint'
| n == "Unique" =
(Nothing, Nothing, takeUniq ps (unEntityNameHS entityName) defs rest, Nothing)
| n == "Foreign" =
(Nothing, Nothing, Nothing, Just $ takeForeign ps entityName rest)
| n == "Primary" =
(Nothing, Just $ takeComposite defNames rest, Nothing, Nothing)
| n == "Id" =
(Just $ takeId ps entityName rest, Nothing, Nothing, Nothing)
| otherwise =
(Nothing, Nothing, takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint
defNames =
map unboundFieldNameHS defs
takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing)
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint ps entityName defs (n :| rest) =
case n of
"Unique" ->
mempty
{ entityConstraintDefsUniques =
pure <$> takeUniq ps (unEntityNameHS entityName) defs rest
}
"Foreign" ->
mempty
{ entityConstraintDefsForeigns =
Just $ pure (takeForeign ps entityName rest)
}
"Primary" ->
mempty
{ entityConstraintDefsPrimaryComposite =
SetOnce (takeComposite (unboundFieldNameHS <$> defs) rest)
}
"Id" ->
mempty
{ entityConstraintDefsIdField =
SetOnce (takeId ps entityName rest)
}
_ | isCapitalizedText n ->
mempty
{ entityConstraintDefsUniques =
pure <$> takeUniq ps "" defs (n : rest)
}
_ ->
mempty
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is much nicer 👍🏻


-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
--
96 changes: 90 additions & 6 deletions persistent/test/Database/Persist/QuasiSpec.hs
Original file line number Diff line number Diff line change
@@ -7,6 +7,7 @@ module Database.Persist.QuasiSpec where

import Prelude hiding (lines)

import Control.Exception
import Data.List hiding (lines)
import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NEL
@@ -23,28 +24,28 @@ import Text.Shakespeare.Text (st)

spec :: Spec
spec = describe "Quasi" $ do
describe "splitExtras" $ do
describe "parseEntityFields" $ do
let helloWorldTokens = Token "hello" :| [Token "world"]
foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]
it "works" $ do
splitExtras []
parseEntityFields []
`shouldBe`
mempty
it "works2" $ do
splitExtras
parseEntityFields
[ Line 0 helloWorldTokens
]
`shouldBe`
( [NEL.toList helloWorldTokens], mempty )
it "works3" $ do
splitExtras
parseEntityFields
[ Line 0 helloWorldTokens
, Line 2 foobarbazTokens
]
`shouldBe`
( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty )
it "works4" $ do
splitExtras
parseEntityFields
[ Line 0 [Token "Product"]
, Line 2 (Token <$> ["name", "Text"])
, Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])
@@ -59,7 +60,7 @@ spec = describe "Quasi" $ do
) ]
)
it "works5" $ do
splitExtras
parseEntityFields
[ Line 0 [Token "Product"]
, Line 2 (Token <$> ["name", "Text"])
, Line 4 [Token "ExtraBlock"]
@@ -339,6 +340,89 @@ Notification
entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"
entityComments (unboundEntityDef vehicle) `shouldBe` Nothing

describe "custom Id column" $ do
it "parses custom Id column" $ do
let definitions = [st|
User
Id Text
name Text
age Int
|]
let [user] = parse lowerCaseSettings definitions
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"
let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))
(fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]
(fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]
(fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"]
(unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`
[ FieldNameHS "name"
, FieldNameHS "age"
]

it "errors on duplicate custom Id column" $ do
let definitions = [st|
User
Id Text
Id Text
name Text
age Int
|]
let [user] = parse lowerCaseSettings definitions
errMsg = [st|expected only one Id declaration per entity|]
evaluate (unboundEntityDef user) `shouldThrow`
errorCall (T.unpack errMsg)

describe "primary declaration" $ do
it "parses Primary declaration" $ do
let definitions = [st|
User
ref Text
name Text
age Int
Primary ref
|]
let [user] = parse lowerCaseSettings definitions
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user"
let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user))
(fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"]
(fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"]
(fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"]
(unboundFieldNameHS <$> unboundEntityFields user) `shouldBe`
[ FieldNameHS "ref"
, FieldNameHS "name"
, FieldNameHS "age"
]

it "errors on duplicate custom Primary declaration" $ do
let definitions = [st|
User
ref Text
name Text
age Int
Primary ref
Primary name
|]
let [user] = parse lowerCaseSettings definitions
errMsg = [st|expected only one Primary declaration per entity|]
evaluate (unboundEntityDef user) `shouldThrow`
errorCall (T.unpack errMsg)

it "errors on conflicting Primary/Id declarations" $ do
let definitions = [st|
User
Id Text
ref Text
name Text
age Int
Primary ref
|]
let [user] = parse lowerCaseSettings definitions
errMsg = [st|Specified both an ID field and a Primary field|]
evaluate (unboundEntityDef user) `shouldThrow`
errorCall (T.unpack errMsg)

describe "foreign keys" $ do
let definitions = [st|
User