Skip to content

Commit

Permalink
Refactor entity constraint parsing in Quasi module (#1315)
Browse files Browse the repository at this point in the history 
* Refactor to semigroup type

* Rename splitExtras

* Extract function

* Update changelog

* Re-inline extracted function

* Implement test for behavior + modelling existing error behavior

* Explicit error functions

* Make semigroup lawful, handle errors externally

* Fix formatting issues
  • Loading branch information
@danbroooks
danbroooks authored Mar 14, 2022
1 parent 2fa3d77 commit 27ae9b5
Show file tree
Hide file tree
Showing 3 changed files with 191 additions and 55 deletions.
2 changes: 2 additions & 0 deletions persistent/ChangeLog.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,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.
Expand Down
148 changes: 99 additions & 49 deletions persistent/Database/Persist/Quasi/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@ module Database.Persist.Quasi.Internal
, parseFieldType
, associateLines
, LinesWithComments(..)
, splitExtras
, parseEntityFields
, takeColsEx
-- * UnboundEntityDef
, UnboundEntityDef(..)
Expand All @@ -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
Expand Down Expand Up @@ -311,7 +310,7 @@ toParsedEntityDef lwc = ParsedEntityDef
_ -> (False, EntityNameHS entityName)

(attribs, extras) =
splitExtras fieldLines
parseEntityFields fieldLines

isDocComment :: Token -> Maybe Text
isDocComment tok =
Expand Down Expand Up @@ -636,7 +635,7 @@ mkUnboundEntityDef
mkUnboundEntityDef ps parsedEntDef =
UnboundEntityDef
{ unboundForeignDefs =
foreigns
entityConstraintDefsForeignsList entityConstraintDefs
, unboundPrimarySpec =
case (idField, primaryComposite) of
(Just {}, Just {}) ->
Expand Down Expand Up @@ -667,7 +666,7 @@ mkUnboundEntityDef ps parsedEntDef =
parsedEntityDefEntityAttributes parsedEntDef
, entityFields =
[]
, entityUniques = uniqs
, entityUniques = entityConstraintDefsUniquesList entityConstraintDefs
, entityForeigns = []
, entityDerives = concat $ mapMaybe takeDerives textAttribs
, entityExtra = parsedEntityDefExtras parsedEntDef
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
--
Expand Down
96 changes: 90 additions & 6 deletions persistent/test/Database/Persist/QuasiSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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"])
Expand All @@ -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"]
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 27ae9b5

Please sign in to comment.