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.

Sign up for GitHub

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
merged 10 commits into from
Mar 14, 2022
Merged

Refactor entity constraint parsing in Quasi module #1315

Show file tree
Hide file tree
Changes from 3 commits
Commits
Show all changes
10 commits
Select commit Hold shift + click to select a range
96aa918
Refactor to semigroup type
danbroooks Sep 7, 2021
76a916f
Rename splitExtras
danbroooks Sep 7, 2021
3547d1e
Extract function
danbroooks Sep 7, 2021
ab76b3a
Update changelog
danbroooks Sep 7, 2021
1d94446
Re-inline extracted function
danbroooks Sep 8, 2021
3318d91
Implement test for behavior + modelling existing error behavior
danbroooks Jan 29, 2022
bedd353
Explicit error functions
danbroooks Jan 29, 2022
1f539dd
Make semigroup lawful, handle errors externally
danbroooks Jan 29, 2022
4e11722
Fix formatting issues
danbroooks Jan 29, 2022
ca84ebd
Merge branch 'master' into quasi-refactor-entity-constraints
danbroooks Jan 29, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
139 changes: 90 additions & 49 deletions persistent/Database/Persist/Quasi/Internal.hs
View file
Open in desktop
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 Down Expand Up @@ -58,7 +58,7 @@ 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 +311,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 +636,7 @@ mkUnboundEntityDef
mkUnboundEntityDef ps parsedEntDef =
UnboundEntityDef
{ unboundForeignDefs =
foreigns
entityConstraintDefsForeignsList entityConstraintDefs
, unboundPrimarySpec =
case (idField, primaryComposite) of
(Just {}, Just {}) ->
Expand Down Expand Up @@ -667,7 +667,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 +689,14 @@ 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 =
entityConstraintDefsIdField entityConstraintDefs

primaryComposite =
entityConstraintDefsPrimaryComposite entityConstraintDefs

cols :: [UnboundFieldDef]
cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs
Expand Down Expand Up @@ -801,11 +798,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,26 +825,31 @@ 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'
in (x, M.insert name (NEL.toList . lineText <$> children) y)
parseExtraBlock name (line :| rest)
ts ->
let (x, y) = splitExtras rest
let (x, y) = parseEntityFields rest
in (ts:x, y)

parseExtraBlock :: Text -> NonEmpty Line -> ([[Token]], M.Map Text [ExtraLine])
parseExtraBlock name (line :| rest) =
(x, M.insert name (NEL.toList . lineText <$> children) y)
where
(children, rest') =
span ((> lineIndent line) . lineIndent) rest

(x, y) =
parseEntityFields rest'

isCapitalizedText :: Text -> Bool
isCapitalizedText t =
not (T.null t) && isUpper (T.head t)
Expand Down Expand Up @@ -928,28 +925,72 @@ getSqlNameOr def =
_ ->
Nothing

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

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

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
Copy link
Contributor Author

@danbroooks danbroooks Sep 7, 2021 •
edited
Loading

Choose a reason for hiding this comment

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

I went with using Semigroups/Monoids for this change, but this implementation of just1 which is used in the semigroup instance makes it unlawful. I could re-write this to not use these typeclasses, but I thought it was a nice refactoring (means I could use foldMap, mempty).

Alternatively this could use something like First or Last, though it is probably a nicer user experience to receive this error than for it to silently proceed using one of the values over the other in the case of duplicate values. In fact that is definitely not what we would want.

It may be that now I have done an initial refactor, I could tweak things further again to not have unlawful instances, and use something instead foldMap / mempty

Copy link
Collaborator

Choose a reason for hiding this comment

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

Hmm! I like using the Monoid and Semigroup instances here. That's neat. But I don't like having a Semigroup operation that will error on a relatively common case - that seems like a footgun.

I feel like a type that better represents this is something like:

data SetOnce a 
    = SetOnce a 
     | NotSet 
     | SetManyTimes (NonEmpty a)

instance Semigroup (SetOnce a) where
    NotSet <> a = a

    SetOnce a <> NotSet = SetOnce a
    SetOnce a <> SetOnce b = SetManyTimes (a :| [b])
    SetOnce a <> SetManyTimes as = SetManyTimes (NEL.cons a as)

    a@(SetManyTimes xs) <> NotSet = a
    SetManyTimes xs <> SetOnce a = SetManyTimes (xs `snoc` a)
    SetManyTimes xs <> SetManyTimes ys = SetManyTimes (xs <> ys)

instance Monoid (SetOnce a) where
    mempty = NotSet

Rendering/erroring can then happen outside of the code.


instance Monoid EntityConstraintDefs where
mempty =
EntityConstraintDefs Nothing Nothing 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 =
Just (takeComposite (unboundFieldNameHS <$> defs) rest)
}
"Id" ->
mempty
{ entityConstraintDefsIdField =
Just (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.
--
Expand Down
12 changes: 6 additions & 6 deletions persistent/test/Database/Persist/QuasiSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,28 +23,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 +59,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