persistent-2.18.1.0: test/Database/Persist/QuasiSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Database.Persist.QuasiSpec where
import Prelude hiding (lines)
import Control.Exception
import Data.Bifunctor
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Database.Persist.EntityDef.Internal
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.Quasi.Internal.ModelParser
import Database.Persist.Quasi.Internal.TypeParser
import Database.Persist.Quasi.PersistSettings
import Database.Persist.Quasi.PersistSettings.Internal
( psQuotedArgumentErrorLevel
, psTabErrorLevel
)
import Database.Persist.Types
import Test.Hspec
import Test.QuickCheck
import Text.Megaparsec (errorBundlePretty, some)
import Text.Shakespeare.Text (st)
defs :: T.Text -> [UnboundEntityDef]
defs = defsWithSettings lowerCaseSettings
defsSnake :: T.Text -> [UnboundEntityDef]
defsSnake = defsWithSettings $ setPsUseSnakeCaseForeignKeys lowerCaseSettings
defsWithWarnings
:: PersistSettings -> T.Text -> (Set ParserWarning, [UnboundEntityDef])
defsWithWarnings ps t = case cpr of
(warnings, Right res) -> (warnings, res)
(_warnings, Left errs) -> error $ renderErrors errs
where
cpr = parse ps [(Nothing, t)]
defsWithSettings :: PersistSettings -> T.Text -> [UnboundEntityDef]
defsWithSettings ps t = snd $ defsWithWarnings ps t
#if MIN_VERSION_megaparsec(9,5,0)
warningSpecs :: Spec
warningSpecs =
describe "Quasi" $ do
describe "psTabErrorLevel parser setting" $ do
let
definitions = T.pack "User\n\tId Text\n\tname String"
(warnings, [user]) =
defsWithWarnings lowerCaseSettings { psTabErrorLevel = Just LevelWarning
}
definitions
it "generates warnings" $ do
Set.map parserWarningMessage warnings
`shouldBe` [ "use spaces instead of tabs\n2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n"
, "use spaces instead of tabs\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n"
]
describe "psQuotedArgumentErrorLevel parser setting" $ do
let
definitions = T.pack "User\n Id \"Text\"\n name String\n deriving \"Eq\""
(warnings, [user]) =
defsWithWarnings lowerCaseSettings { psQuotedArgumentErrorLevel = Just LevelWarning
}
definitions
it "generates warnings" $ do
Set.map parserWarningMessage warnings
`shouldBe` ["Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0\n2:5:\n |\n2 | Id \"Text\"\n | ^\nUnexpected quotation mark in field or directive attribute\n","Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0\n4:11:\n |\n4 | deriving \"Eq\"\n | ^\nUnexpected quotation mark in field or directive attribute\n"]
#else
warningSpecs :: Spec
warningSpecs = pure ()
#endif
spec :: Spec
spec = describe "Quasi" $ do
describe "takeColsEx" $ do
let
subject = takeColsEx upperCaseSettings
it "fails on a single word" $ do
subject ["asdf"]
`shouldBe` Nothing
it "errors on invalid input" $ do
evaluate (subject ["name", "int"])
`shouldErrorWithMessage` "Invalid field type \"int\" PSFail \"int\""
it "works if it has a name and a type" $ do
subject ["asdf", "Int"]
`shouldBe` Just
UnboundFieldDef
{ unboundFieldNameHS = FieldNameHS "asdf"
, unboundFieldNameDB = FieldNameDB "asdf"
, unboundFieldType = FTTypeCon Nothing "Int"
, unboundFieldAttrs = []
, unboundFieldStrict = True
, unboundFieldCascade = noCascade
, unboundFieldComments = Nothing
, unboundFieldGenerated = Nothing
}
it "works if it has a name, type, and cascade" $ do
subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"]
`shouldBe` Just
UnboundFieldDef
{ unboundFieldNameHS = FieldNameHS "asdf"
, unboundFieldNameDB = FieldNameDB "asdf"
, unboundFieldType = FTTypeCon Nothing "Int"
, unboundFieldAttrs = []
, unboundFieldStrict = True
, unboundFieldCascade = FieldCascade (Just Cascade) (Just Cascade)
, unboundFieldComments = Nothing
, unboundFieldGenerated = Nothing
}
it "never tries to make a refernece" $ do
subject ["asdf", "UserId", "OnDeleteCascade"]
`shouldBe` Just
UnboundFieldDef
{ unboundFieldNameHS = FieldNameHS "asdf"
, unboundFieldNameDB = FieldNameDB "asdf"
, unboundFieldType = FTTypeCon Nothing "UserId"
, unboundFieldAttrs = []
, unboundFieldStrict = True
, unboundFieldCascade = FieldCascade Nothing (Just Cascade)
, unboundFieldComments = Nothing
, unboundFieldGenerated = Nothing
}
describe "type parsing" $ do
let
parseType :: String -> ParseResult TypeExpr
parseType s = do
let
(warnings, res) =
runConfiguredParser defaultPersistSettings initialExtraState innerTypeExpr "" s
case res of
Left peb -> (warnings, Left peb)
Right (te, _acc) -> (warnings, Right te)
isType typeStr expectedTypeExpr = do
let
(_warnings, Right te) = parseType typeStr
te `shouldBe` expectedTypeExpr
typeExprContent te `shouldBe` T.pack typeStr
-- these are some helper functions to make expectations less verbose
simpleType s = (TypeApplication (TypeConstructorExpr (TypeConstructor s)) [])
typeApp s ts = (TypeApplication (TypeConstructorExpr (TypeConstructor s)) ts)
listOf t = (TypeApplication (TypeConstructorExpr ListConstructor) [t])
it "parses types of kind '*'" $ do
"String" `isType` simpleType "String"
it "parses type constructors with dots" $ do
"ThisIs.AType" `isType` simpleType "ThisIs.AType"
it "parses higher-kinded types" $ do
"Maybe String" `isType` typeApp "Maybe" [simpleType "String"]
it "is greedy when parsing arguments to a type constructor" $ do
"Map String Int" `isType` typeApp "Map" [simpleType "String", simpleType "Int"]
it "parses higher-kinded types when parameterized by complex types (1)" $ do
"Map String (Maybe [Int])"
`isType` typeApp "Map" [simpleType "String", typeApp "Maybe" [listOf (simpleType "Int")]]
it "parses higher-kinded types when parameterized by complex types (2)" $ do
"Map (Maybe Int) [Int]"
`isType` typeApp "Map" [(typeApp "Maybe" [simpleType "Int"]), listOf (simpleType "Int")]
it "parses type expressions constructed by a partially parameterized type" $ do
"(Map String) [Int]"
`isType` TypeApplication
(typeApp "Map" [(simpleType "String")])
[listOf (simpleType "Int")]
it "parses lists of lists" $ do
"[[Maybe String]]"
`isType` listOf (listOf (typeApp "Maybe" [simpleType "String"]))
it "parses list types of complex types" $ do
"[(Map String) [Int]]"
`isType` listOf
( TypeApplication
(typeApp "Map" [(simpleType "String")])
[listOf (simpleType "Int")]
)
it "parses type-level String literals" $ do
"Labelled \"abcd\"" `isType` typeApp "Labelled" [TypeLitString "abcd"]
it "parses type-level Int literals" $ do
"Val 3" `isType` typeApp "Val" [TypeLitInt "3"]
it "parses promoted type constructors" $ do
"'Maybe" `isType` TypeLitPromotedConstructor (TypeConstructor "Maybe")
describe "field name parsing" $ do
let
parseFieldName :: String -> ParseResult FieldName
parseFieldName s = do
let
(warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState fieldName "" s
case res of
Left peb ->
(warnings, Left peb)
Right (fn, _acc) -> (warnings, Right fn)
it "parses alphanumeric field names" $
parseFieldName "asdf100"
`shouldBe` ([], Right (FieldName "asdf100"))
it "parses alphanumeric field names with underscores" $
parseFieldName "asdf_100"
`shouldBe` ([], Right (FieldName "asdf_100"))
describe "attribute parsing" $ do
let
parseAttributes :: String -> ParseResult [Attribute]
parseAttributes s = do
let
(warnings, res) =
runConfiguredParser
defaultPersistSettings
initialExtraState
(some attribute)
""
s
case res of
Left peb ->
(warnings, Left peb)
Right (tokens, _acc) -> (warnings, Right tokens)
it "handles normal words" $
parseAttributes "foo bar baz"
`shouldBe` ( []
, Right
( [ PText "foo"
, PText "bar"
, PText "baz"
]
)
)
it "handles bangs" $
parseAttributes "foo !bar baz"
`shouldBe` ( []
, Right
( [ PText "foo"
, PText "!bar"
, PText "baz"
]
)
)
it "handles numbers" $
parseAttributes "one (Finite 1)"
`shouldBe` ( []
, Right
( [ PText "one"
, Parenthetical "Finite 1"
]
)
)
it "handles quotes" $
parseAttributes "abc=\"foo bar\" def=\"baz\""
`shouldBe` ( []
, Right
( [ Assignment "abc" "foo bar"
, Assignment "def" "baz"
]
)
)
it "handles SQL literals with no specified type" $
parseAttributes "attr='[\"ab\\'cd\", 1, 2]'"
`shouldBe` ( []
, Right
([Assignment "attr" "'[\"ab'cd\", 1, 2]'"])
)
it "handles SQL literals with a specified type" $
parseAttributes "attr='{\"\\'a\\'\": [1, 2.2, \"\\'3\\'\"]}'::type_name"
`shouldBe` ( []
, Right
([Assignment "attr" "'{\"'a'\": [1, 2.2, \"'3'\"]}'::type_name"])
)
it "handles commas in tokens" $
parseAttributes "x=COALESCE(left,right) baz"
`shouldBe` ( []
, Right
( [ Assignment "x" "COALESCE(left,right)"
, PText "baz"
]
)
)
it "handles single quotes in tokens" $
parseAttributes "x=blorp('blap') baz"
`shouldBe` ( []
, Right
( [ Assignment "x" "blorp('blap')"
, PText "baz"
]
)
)
it "handles spaces in assignment RHSes" $
parseAttributes "sql=blorp('blap', 'blip') baz"
`shouldBe` ( []
, Right
( [ Assignment "sql" "blorp('blap', 'blip')"
, PText "baz"
]
)
)
it "handles quotes mid-token" $
parseAttributes "x=\"foo bar\" baz"
`shouldBe` ( []
, Right
( [ Assignment "x" "foo bar"
, PText "baz"
]
)
)
it "handles escaped quotes mid-token" $
parseAttributes "x=\\\"foo bar\" baz"
`shouldBe` ( []
, Right
( [ Assignment "x" "\\\"foo"
, PText "bar\""
, PText "baz"
]
)
)
it "handles unnested parentheses" $
parseAttributes "(foo bar) (baz)"
`shouldBe` ( []
, Right
( [ Parenthetical "foo bar"
, Parenthetical "baz"
]
)
)
it "handles unnested parentheses mid-token" $
parseAttributes "x=(foo bar) (baz)"
`shouldBe` ( []
, Right
( [ Assignment "x" "foo bar"
, Parenthetical "baz"
]
)
)
it "handles nested parentheses" $
parseAttributes "(foo (bar)) (baz)"
`shouldBe` ( []
, Right
( [ Parenthetical "foo (bar)"
, Parenthetical "baz"
]
)
)
it "handles escaped quotation marks in plain tokens" $
parseAttributes "foo bar\\\"baz"
`shouldBe` ( []
, Right
( [ PText "foo"
, PText "bar\\\"baz"
]
)
)
it "handles escaped quotation marks in quotations" $
parseAttributes "foo bar=\"baz\\\"quux\""
`shouldBe` ( []
, Right
( [ PText "foo"
, Assignment "bar" "baz\"quux"
]
)
)
it "handles escaped quotation marks in equalities" $
parseAttributes "y=\"baz\\\"\""
`shouldBe` ( []
, Right
( [ Assignment "y" "baz\""
]
)
)
it "handles escaped quotation marks in parentheticals" $
parseAttributes "(foo \\\"bar)"
`shouldBe` ( []
, Right
( [ Parenthetical "foo \\\"bar"
]
)
)
it "handles escaped parentheses in quotations" $
parseAttributes "foo bar=\"baz\\(quux\""
`shouldBe` ( []
, Right
( [ PText "foo"
, Assignment "bar" "baz(quux"
]
)
)
it "handles escaped parentheses in plain tokens" $
parseAttributes "foo bar\\(baz"
`shouldBe` ( []
, Right
( [ PText "foo"
, PText "bar(baz"
]
)
)
it "handles escaped parentheses in parentheticals" $
parseAttributes "(foo \\(bar)"
`shouldBe` ( []
, Right
( [ Parenthetical "foo (bar"
]
)
)
it "handles escaped parentheses in equalities" $
parseAttributes "y=baz\\("
`shouldBe` ( []
, Right
( [ Assignment "y" "baz("
]
)
)
it "handles mid-token quote in later token" $
parseAttributes "foo bar baz=(bin\")"
`shouldBe` ( []
, Right
( [ PText "foo"
, PText "bar"
, Assignment "baz" "bin\""
]
)
)
describe "entity field parsing" $ do
let
parseField :: String -> ParseResult ()
parseField s = do
let
(warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState entityField "" s
case res of
Left peb ->
(warnings, Left peb)
Right (_, _) -> (warnings, Right ())
it "should error if quotes are unterminated in an attribute" $ do
(fmap . first) errorBundlePretty (parseField "field String sql=\"foo bar")
`shouldBe` ( []
, Left
( "1:17:\n |\n1 | field String sql=\"foo bar\n | ^\nunexpected '='\nexpecting '!', '\"', ''', ',', '-', '.', ':', '[', '\\', ']', '_', '~', alphanumeric character, assignment expression, end of input, newline, parenthetical, or plain attribute\n"
)
)
it "should error if quotes are unterminated in a type" $ do
(fmap . first) errorBundlePretty (parseField "field (Label \"unterminated)")
`shouldBe` ( []
, Left
( "1:28:\n |\n1 | field (Label \"unterminated)\n | ^\nunexpected end of input\nexpecting '\"' or literal character\n"
)
)
describe "tab error level setting" $ do
let
definitions = T.pack "User\n\tId Text\n\tname String"
describe "when configured to permit tabs" $ do
let
(warnings, [user]) = defsWithWarnings lowerCaseSettings{psTabErrorLevel = Nothing} definitions
it "permits tab indentation" $
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
describe "when configured to warn on tabs" $ do
let
(warnings, [user]) =
defsWithWarnings
lowerCaseSettings{psTabErrorLevel = Just LevelWarning}
definitions
it "permits tab indentation" $
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
describe "when configured to disallow tabs" $ do
let
[user] =
defsWithSettings
lowerCaseSettings{psTabErrorLevel = Just LevelError}
definitions
it "rejects tab indentation" $
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` "2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n"
describe "quoted attribute error level setting" $ do
let
definitions = T.pack "User\n name String \"Maybe\""
describe "when configured to warn on quoted attributes" $ do
let
(warnings, [user]) =
defsWithWarnings
lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelWarning}
definitions
it "permits quoted attributes" $
(unboundFieldAttrs <$> unboundEntityFields user) `shouldBe` [[FieldAttrMaybe]]
describe "when configured to disallow quoted attributes" $ do
let
(warnings, [user]) =
defsWithWarnings
lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError}
definitions
it "rejects quoted attributes" $
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` "2:14:\n |\n2 | name String \"Maybe\"\n | ^\nUnexpected quotation mark in field or directive attribute\n"
describe "and the definition has quotation marks in the type" $ do
let
definitionsWithTypeLevelString = T.pack "User\n name \"String\"\n deriving Show"
(warnings2, [user]) =
defsWithWarnings
lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError}
definitionsWithTypeLevelString
it "parses successfully" $
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
describe "quoted directive argument error level setting" $ do
let
definitions = T.pack "User\n name String\n deriving \"Show\""
describe "when configured to warn on quoted arguments" $ do
let
(warnings, [user]) =
defsWithWarnings
lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelWarning}
definitions
it "permits quoted attributes" $
getUnboundEntityNameHS user `shouldBe` EntityNameHS "User"
describe "when configured to disallow quoted arguments" $ do
let
(warnings, [user]) =
defsWithWarnings
lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError}
definitions
it "rejects quoted arguments" $
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` "3:11:\n |\n3 | deriving \"Show\"\n | ^\nUnexpected quotation mark in field or directive attribute\n"
describe "parse" $ do
let
subject =
[st|
Bicycle -- | this is a bike
brand String -- | the brand of the bike
ExtraBike
foo bar -- | this is a foo bar
baz
deriving Eq
-- | This is a Car
Car
-- | the make of the Car
make String
-- | the model of the Car
model String
UniqueModel model
deriving Eq Show
+Vehicle
bicycle BicycleId -- | the bike reference
car CarId -- | the car reference
|]
let
[bicycle, car, vehicle] = defs subject
it "should parse the `entityHaskell` field" $ do
getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle"
getUnboundEntityNameHS car `shouldBe` EntityNameHS "Car"
getUnboundEntityNameHS vehicle `shouldBe` EntityNameHS "Vehicle"
it "should parse the `entityDB` field" $ do
entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle"
entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car"
entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle"
it "should parse the `entityAttrs` field" $ do
entityAttrs (unboundEntityDef bicycle) `shouldBe` []
entityAttrs (unboundEntityDef car) `shouldBe` []
entityAttrs (unboundEntityDef vehicle) `shouldBe` []
it "should parse the `unboundEntityFields` field" $ do
let
simplifyField field =
(unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field)
(simplifyField <$> unboundEntityFields bicycle)
`shouldBe` [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)
]
(simplifyField <$> unboundEntityFields car)
`shouldBe` [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")
, (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")
]
(simplifyField <$> unboundEntityFields vehicle)
`shouldBe` [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)
, (FieldNameHS "car", FieldNameDB "car", Nothing)
]
it "should parse the `entityUniques` field" $ do
let
simplifyUnique unique =
(uniqueHaskell unique, uniqueFields unique)
(simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` []
(simplifyUnique <$> entityUniques (unboundEntityDef car))
`shouldBe` [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])
]
(simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` []
it "should parse quoted attributes" $ do
let
[precompiledCacheParent] =
defs
[st|
PrecompiledCacheParent sql="precompiled_cache"
platformGhcDir FilePath "default=(hex(randomblob(16)))"
deriving Show
|]
(unboundFieldAttrs <$> unboundEntityFields precompiledCacheParent)
`shouldBe` [[FieldAttrDefault "(hex(randomblob(16)))"]]
it "should parse entity block attributes with nested parens on equality rhs" $ do
let
[precompiledCacheParent] =
defs
[st|
PrecompiledCacheParent sql="precompiled_cache"
platformGhcDir FilePath default=(hex(randomblob(16)))
|]
(unboundFieldAttrs <$> unboundEntityFields precompiledCacheParent)
`shouldBe` [[FieldAttrDefault "hex(randomblob(16))"]]
it "should parse the `entityForeigns` field" $ do
let
[user, notification] =
defs
[st|
User
name Text
emailFirst Text
emailSecond Text
!yes Int
~no Int
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
|]
unboundForeignDefs user `shouldBe` []
map unboundForeignDef (unboundForeignDefs notification)
`shouldBe` [ ForeignDef
{ foreignRefTableHaskell = EntityNameHS "User"
, foreignRefTableDBName = EntityNameDB "user"
, foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"
, foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"
, foreignFieldCascade = FieldCascade Nothing Nothing
, foreignFields =
[]
, -- the foreign fields are not set yet in an unbound
-- entity def
foreignAttrs = []
, foreignNullable = False
, foreignToPrimary = False
}
]
it "should parse the `entityDerives` field" $ do
entityDerives (unboundEntityDef bicycle) `shouldBe` ["Eq"]
entityDerives (unboundEntityDef car) `shouldBe` ["Eq", "Show"]
entityDerives (unboundEntityDef vehicle) `shouldBe` []
it "should parse the `entityEntities` field" $ do
entityExtra (unboundEntityDef bicycle)
`shouldBe` Map.singleton "ExtraBike" [["foo", "bar"], ["baz"]]
entityExtra (unboundEntityDef car) `shouldBe` mempty
entityExtra (unboundEntityDef vehicle) `shouldBe` mempty
it "should parse the `entitySum` field" $ do
entitySum (unboundEntityDef bicycle) `shouldBe` False
entitySum (unboundEntityDef car) `shouldBe` False
entitySum (unboundEntityDef vehicle) `shouldBe` True
it "should parse the `entityComments` field" $ do
entityComments (unboundEntityDef bicycle) `shouldBe` Nothing
entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"
entityComments (unboundEntityDef vehicle) `shouldBe` Nothing
it "should error on malformed input, unterminated parens" $ do
let
definitions =
[st|
User
name Text
age (Maybe Int
|]
let
[user] = defs definitions
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` "4:20:\n |\n4 | age (Maybe Int\n | ^\nunexpected newline\nexpecting ''', ')', '.', alphanumeric character, type expression, or white space\n"
it "errors on duplicate cascade update declarations" $ do
let
definitions =
[st|
User
age Int OnUpdateCascade OnUpdateCascade
|]
let
[user] = defs definitions
mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)
`shouldErrorWithMessage` "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]"
it "errors on duplicate cascade delete declarations" $ do
let
definitions =
[st|
User
age Int OnDeleteCascade OnDeleteCascade
|]
let
[user] = defs definitions
mapM (evaluate . unboundFieldCascade) (unboundEntityFields user)
`shouldErrorWithMessage` "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]"
describe "custom Id column" $ do
it "parses custom Id column" $ do
let
definitions =
[st|
User
Id Text
name Text
age Int
|]
let
[user] = defs 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] = defs definitions
errMsg = [st|expected only one Id declaration per entity|]
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` (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] = defs 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"
]
entityUniques (unboundEntityDef user)
`shouldBe` [ UniqueDef
{ uniqueHaskell =
ConstraintNameHS "UserPrimaryKey"
, uniqueDBName =
ConstraintNameDB "primary_key"
, uniqueFields =
pure (FieldNameHS "ref", FieldNameDB "ref")
, uniqueAttrs =
[]
}
]
it "errors on duplicate custom Primary declaration" $ do
let
definitions =
[st|
User
ref Text
name Text
age Int
Primary ref
Primary name
|]
let
[user] = defs definitions
errMsg = "expected only one Primary declaration per entity"
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` 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] = defs definitions
errMsg = [st|Specified both an ID field and a Primary field|]
evaluate (unboundEntityDef user)
`shouldErrorWithMessage` (T.unpack errMsg)
it "triggers error on invalid declaration" $ do
let
definitions =
[st|
User
age Text
Primary ref
|]
let
[user] = defs definitions
case unboundPrimarySpec user of
NaturalKey ucd -> do
evaluate (NEL.head $ unboundCompositeCols ucd)
`shouldErrorWithMessage` "Unknown column in primary key constraint: \"ref\""
_ ->
error "Expected NaturalKey, failing"
describe "entity unique constraints" $ do
it "triggers error if declared field does not exist" $ do
let
definitions =
[st|
User
name Text
emailFirst Text
UniqueEmail emailFirst emailSecond
|]
let
[user] = defs definitions
uniques = entityUniques (unboundEntityDef user)
[dbNames] = fmap snd . uniqueFields <$> uniques
errMsg =
unwords
[ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\""
, "possible fields: [\"name\",\"emailFirst\"]"
]
evaluate (head (NEL.tail dbNames))
`shouldErrorWithMessage` errMsg
it "triggers error if no valid constraint name provided" $ do
let
definitions =
[st|
User
age Text
Unique some
|]
let
[user] = defs definitions
evaluate (unboundPrimarySpec user)
`shouldErrorWithMessage` "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]"
describe "foreign keys" $ do
let
validDefinitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
|]
it "should allow you to modify the FK name via provided function" $ do
let
flippedFK (EntityNameHS entName) (ConstraintNameHS conName) =
conName <> entName
[_user, notification] = defsWithSettings (setPsToFKName flippedFK lowerCaseSettings) validDefinitions
[notificationForeignDef] =
unboundForeignDef <$> unboundForeignDefs notification
foreignConstraintNameDBName notificationForeignDef
`shouldBe` ConstraintNameDB "fk_noti_user_notification"
it "should error when insufficient params provided" $ do
let
definitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User
|]
let
[_user, notification] = defsSnake definitions
mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
`shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]"
it "should error when foreign fields not provided" $ do
let
definitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User fk_noti_user
|]
let
[_user, notification] = defsSnake definitions
mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
`shouldErrorWithMessage` "No fields on foreign reference."
it "should error when number of parent and foreign fields differ" $ do
let
definitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst
|]
let
[_user, notification] = defsSnake definitions
mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
`shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields"
it
"should throw error when there is more than one delete cascade on the declaration"
$ do
let
definitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User OnDeleteCascade OnDeleteCascade
|]
let
[_user, notification] = defsSnake definitions
mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
`shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions"
it
"should throw error when there is more than one update cascade on the declaration"
$ do
let
definitions =
[st|
User
name Text
emailFirst Text
emailSecond Text
UniqueEmail emailFirst emailSecond
Notification
content Text
sentToFirst Text
sentToSecond Text
Foreign User OnUpdateCascade OnUpdateCascade
|]
let
[_user, notification] = defsSnake definitions
mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification)
`shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions"
it
"should allow you to enable snake cased foriegn keys via a preset configuration function"
$ do
let
[_user, notification] =
defsSnake validDefinitions
[notificationForeignDef] =
unboundForeignDef <$> unboundForeignDefs notification
foreignConstraintNameDBName notificationForeignDef
`shouldBe` ConstraintNameDB "notification_fk_noti_user"
describe "ticked types" $ do
it "should be able to parse ticked types" $ do
let
simplifyField field =
(unboundFieldNameHS field, unboundFieldType field)
let
tickedDefinition =
[st|
CustomerTransfer
customerId CustomerId
moneyAmount (MoneyAmount 'Customer 'Debit)
currencyCode CurrencyCode
uuid TransferUuid
|]
let
[customerTransfer] = defs tickedDefinition
let
expectedType =
FTTypeCon Nothing "MoneyAmount"
`FTApp` FTTypePromoted "Customer"
`FTApp` FTTypePromoted "Debit"
(simplifyField <$> unboundEntityFields customerTransfer)
`shouldBe` [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId")
, (FieldNameHS "moneyAmount", expectedType)
, (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode")
, (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid")
]
describe "type literals" $ do
it "should be able to parse type literals" $ do
let
simplifyField field =
(unboundFieldNameHS field, unboundFieldType field)
let
tickedDefinition =
[st|
WithFinite
one (Finite 1)
twenty (Labelled "twenty")
|]
let
[withFinite] = defs tickedDefinition
(simplifyField <$> unboundEntityFields withFinite)
`shouldBe` [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)))
,
( FieldNameHS "twenty"
, FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))
)
]
describe "parseFieldType" $ do
it "simple types" $
parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")
it "module types" $
parseFieldType "Data.Map.FooBar"
`shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")
it "application" $
parseFieldType "Foo Bar"
`shouldBe` Right
(FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
it "application multiple" $
parseFieldType "Foo Bar Baz"
`shouldBe` Right
( (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
`FTApp` FTTypeCon Nothing "Baz"
)
it "parens" $ do
let
foo = FTTypeCon Nothing "Foo"
bar = FTTypeCon Nothing "Bar"
baz = FTTypeCon Nothing "Baz"
parseFieldType "Foo (Bar Baz)"
`shouldBe` Right
(foo `FTApp` (bar `FTApp` baz))
it "lists" $ do
let
foo = FTTypeCon Nothing "Foo"
bar = FTTypeCon Nothing "Bar"
bars = FTList bar
baz = FTTypeCon Nothing "Baz"
parseFieldType "Foo [Bar] Baz"
`shouldBe` Right
(foo `FTApp` bars `FTApp` baz)
it "numeric type literals" $ do
let
expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))
parseFieldType "Finite 1" `shouldBe` Right expected
it "string type literals" $ do
let
expected = FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))
parseFieldType "Labelled \"twenty\"" `shouldBe` Right expected
it "nested list / parens (list inside parens)" $ do
let
maybeCon = FTTypeCon Nothing "Maybe"
int = FTTypeCon Nothing "Int"
parseFieldType "Maybe (Maybe [Int])"
`shouldBe` Right
(maybeCon `FTApp` (maybeCon `FTApp` FTList int))
it "nested list / parens (parens inside list)" $ do
let
maybeCon = FTTypeCon Nothing "Maybe"
int = FTTypeCon Nothing "Int"
parseFieldType "[Maybe (Maybe Int)]"
`shouldBe` Right
(FTList (maybeCon `FTApp` (maybeCon `FTApp` int)))
it "fails on lowercase starts" $ do
parseFieldType "nothanks" `shouldBe` Left "PSFail \"nothanks\""
describe "#1175 empty entity" $ do
let
subject =
[st|
Foo
name String
age Int
EmptyEntity
Bar
name String
Baz
a Int
b String
c FooId
|]
it "parse works" $ do
let
test name'fieldCount parsedList = do
case (name'fieldCount, parsedList) of
([], []) ->
pure ()
((name, fieldCount) : _, []) ->
expectationFailure $
"Expected an entity with name "
<> name
<> " and "
<> show fieldCount
<> " fields"
<> ", but the list was empty..."
((name, fieldCount) : ys, (x : xs)) -> do
let
UnboundEntityDef{..} =
x
(unEntityNameHS (getUnboundEntityNameHS x), length unboundEntityFields)
`shouldBe` (T.pack name, fieldCount)
test ys xs
([], _ : _) ->
expectationFailure
"more entities parsed than expected"
result =
defs subject
length result `shouldBe` 4
test
[ ("Foo", 2)
, ("EmptyEntity", 0)
, ("Bar", 1)
, ("Baz", 3)
]
result
arbitraryWhiteSpaceChar :: Gen Char
arbitraryWhiteSpaceChar =
oneof $ pure <$> [' ', '\t', '\n', '\r']
shouldErrorWithMessage :: IO a -> String -> Expectation
shouldErrorWithMessage action expectedMsg = do
res <- try action
case res of
Left (ErrorCall msg) ->
msg `shouldBe` expectedMsg
_ ->
expectationFailure "Expected `error` to have been called"