diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for persistent-parser +## 0.1.0.1 -- 2016-09-08 + +* Add test files to other-modules so sdist will package them in the tar.gz. + ## 0.1.0.0 -- 2016-09-08 * Parse persistent files into a syntax tree. diff --git a/persistent-parser.cabal b/persistent-parser.cabal --- a/persistent-parser.cabal +++ b/persistent-parser.cabal @@ -1,5 +1,5 @@ name: persistent-parser -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Parse persistent model files description: Parse persistent model files license: BSD3 @@ -25,6 +25,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: Database.Persist.ParserSpec default-language: Haskell2010 hs-source-dirs: tests diff --git a/tests/Database/Persist/ParserSpec.hs b/tests/Database/Persist/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Database/Persist/ParserSpec.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Persist.ParserSpec ( + main + , spec + ) where + +import Data.Attoparsec.Text +import Data.Either +import Database.Persist.Internal.Parser +import Database.Persist.Syntax.Types +import Test.Hspec + +spec :: Spec +spec = do + describe "Haskell Function Name Parser" $ do + -- should pass + it "Should parse function names starting with an underscore" $ do + let parseResult = parseOnly haskellFunctionName "_get" + parseResult `shouldBe` (Right "_get") + + it "Should parse function names starting with a lowercase letter" $ do + let parseResult = parseOnly haskellFunctionName "get" + parseResult `shouldBe` (Right "get") + + it "Should parse function names with an numbers" $ do + let parseResult = parseOnly haskellFunctionName "get1" + parseResult `shouldBe` (Right "get1") + + it "Should parse function names and ignore the trailing whitespace" $ do + let parseResult = parseOnly haskellFunctionName "get " + parseResult `shouldBe` (Right "get") + + it "Should parse function names, ignore the trailing whitespace, and the things that follow the whitespace" $ do + let parseResult = parseOnly haskellFunctionName "get anotherthing" + parseResult `shouldBe` (Right "get") + + -- should fail + it "Should not parse inputs that start with whitespace" $ do + let parseResult = parseOnly haskellFunctionName " _get" + isLeft parseResult `shouldBe` True + + it "Should not parse function names starting with an uppercase letter" $ do + let parseResult = parseOnly haskellFunctionName "Get" + isLeft parseResult `shouldBe` True + + it "Should not parse function names starting with a number" $ do + let parseResult = parseOnly haskellFunctionName "1get" + isLeft parseResult `shouldBe` True + + it "Should not parse function names with symbols other than letters, numbers and underscores" $ do + let parseResults = [ parseOnly haskellFunctionName "get!" + , parseOnly haskellFunctionName "get$" + , parseOnly haskellFunctionName "get+" + , parseOnly haskellFunctionName "get=" + , parseOnly haskellFunctionName "get-" + ] + (rights parseResults) `shouldMatchList` [] + + describe "Haskell Type Name Parser" $ do + -- should pass + it "Should parse type names starting with an uppercase letter" $ do + let parseResult = parseOnly haskellTypeName "Person" + parseResult `shouldBe` (Right "Person") + + it "Should parse type names starting with an uppercase letter" $ do + let parseResult = parseOnly haskellTypeName "Person" + parseResult `shouldBe` (Right "Person") + + it "Should parse strict type names" $ do + let parseResult = parseOnly haskellTypeName "!Get" + parseResult `shouldBe` (Right "Get") + + -- parseResult `shouldBe` (Right "!Get") + + it "Should parse lazy type names" $ do + let parseResult = parseOnly haskellTypeName "~Get" + parseResult `shouldBe` (Right "Get") + + + + -- should fail + + it "Should not parse type names starting with a lowercase letter" $ do + let parseResult = parseOnly haskellTypeName "person" + isLeft parseResult `shouldBe` True + + it "Should not parse type names with symbols other than letters, numbers and underscores" $ do + let parseResults = [ parseOnly haskellTypeName "Get!" + , parseOnly haskellTypeName "Get$" + , parseOnly haskellTypeName "Get+" + , parseOnly haskellTypeName "Get=" + , parseOnly haskellTypeName "Get-" + ] + (rights parseResults) `shouldMatchList` [] + + describe "parseEntityPrimary" $ do + it "should parse" $ do + let parseResult = parseOnly parseEntityPrimary " Primary name age" + parseResult `shouldBe` (Right (EntityPrimary ["name","age"])) + + describe "parseEntityForeign" $ do + it "should parse" $ do + let parseResult = parseOnly parseEntityForeign " Foreign Tree fkparent parent" + parseResult `shouldBe` (Right (EntityForeign "Tree" ["fkparent","parent"])) + + + describe "parseMigrationOnlyAndSafeToRemove" $ do + + it "Should parse MigrationOnly" $ do + let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " MigrationOnly" + parseResult `shouldBe` (Right [MigrationOnly]) + + it "Should parse SafeToRemove" $ do + let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " SafeToRemove" + parseResult `shouldBe` (Right [SafeToRemove]) + + it "Should parse empty space" $ do + let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " " + parseResult `shouldBe` (Right []) + + it "Should parse MigrationOnly and SafeToRemove" $ do + let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " MigrationOnly SafeToRemove" + parseResult `shouldBe` (Right [MigrationOnly,SafeToRemove]) + + it "Should parse SafeToRemove and MigrationOnly" $ do + let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " SafeToRemove MigrationOnly" + parseResult `shouldBe` (Right [SafeToRemove,MigrationOnly]) + + describe "parseEntityFieldLastItem" $ do + it "Should parse a default assignment" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing" + parseResult `shouldBe` (Right [(FieldDefault "Nothing")]) + + it "Should parse an sql row assignment" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " sql=person" + parseResult `shouldBe` (Right [(FieldSqlRow "person")]) + + it "Should parse an sql type assignment" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " sqltype=date" + parseResult `shouldBe` (Right [(FieldSqlType "date")]) + + it "Should parse an maxlen assignment" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " maxlen=15" + parseResult `shouldBe` (Right [(FieldMaxLen 15)]) + + it "Should parse mulitple items" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing maxlen=15" + parseResult `shouldBe` (Right [(FieldDefault "Nothing"), (FieldMaxLen 15)]) + + it "Should parse mulitple items" $ do + let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing maxlen=15 sqltype=date sql=person" + parseResult `shouldBe` (Right [(FieldDefault "Nothing"), (FieldMaxLen 15),(FieldSqlType "date"), (FieldSqlRow "person")]) + + + describe "parseEntity" $ do + it "parses Entity with only a table name" $ do + let parseResult = parseOnly (parseEntity) "Person" + parseResult `shouldBe` (Right (Entity "Person" False Nothing [])) + + it "parses Entity with table name and derive json" $ do + let parseResult = parseOnly (parseEntity) "Person json" + parseResult `shouldBe` (Right (Entity "Person" True Nothing [])) + + it "parses Entity with table name and sql table set to person" $ do + let parseResult = parseOnly (parseEntity) "Person sql = person" + parseResult `shouldBe` (Right (Entity "Person" False (Just "person") [])) + + it "parses Entity with table name, derive json, and table set to person" $ do + let parseResult = parseOnly (parseEntity) "Person json sql= person" + parseResult `shouldBe` (Right (Entity "Person" True (Just "person") [])) + + it "parses Entity with table name and one field" $ do + let parseResult = parseOnly (parseEntity) "Person\n name Text" + parseResult `shouldBe` (Right (Entity "Person" False Nothing [(EntityChildEntityField $ EntityField "name" (EntityFieldType "Text" Strict False False) False False Nothing Nothing Nothing Nothing)])) + + it "parses Entity with a table name, multiple fields, Unique, Foreign and deriving" $ do + let parseResult = parseOnly (parseEntity) "Person\n name Text\n phoneNumber Int Maybe\n friends [PersonId]\n UniquePerson name\n deriving Eq Read Show\n Primary name age" + parseResult `shouldBe` (Right (Entity "Person" False Nothing [(EntityChildEntityField $ EntityField "name" (EntityFieldType "Text" Strict False False) False False Nothing Nothing Nothing Nothing) + ,(EntityChildEntityField $ EntityField "phoneNumber" (EntityFieldType "Int" Strict False True) False False Nothing Nothing Nothing Nothing) + ,(EntityChildEntityField $ EntityField "friends" (EntityFieldType "PersonId" Strict True False) False False Nothing Nothing Nothing Nothing) + ,(EntityChildEntityUnique $ EntityUnique "UniquePerson" ["name"]) + ,(EntityChildEntityDerive $ EntityDerive ["Eq","Read","Show"]) + ,(EntityChildEntityPrimary $ EntityPrimary ["name","age"])])) + + + + + describe "parseEntityField" $ do + it "Should parse a well formed entity field" $ do + let sampleEntityField = " ident Text" + let eft = EntityFieldType "Text" Strict False False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with a list type" $ do + let sampleEntityField = " ident [Text]" + let eft = EntityFieldType "Text" Strict True False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with a maybe type" $ do + let sampleEntityField = " ident Text Maybe" + let eft = EntityFieldType "Text" Strict False True + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with a maybe list type" $ do + let sampleEntityField = " ident [Text] Maybe" + let eft = EntityFieldType "Text" Strict True True + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + + it "Should parse an entity field with explicit a strict type" $ do + let sampleEntityField = " ident !Text" + let eft = EntityFieldType "Text" ExplicitStrict False False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + it "Should parse an entity field with a lazy type" $ do + let sampleEntityField = " ident ~Text" + let eft = EntityFieldType "Text" Lazy False False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + it "Should parse an entity field with a list of lazy types" $ do + let sampleEntityField = " ident [~Text]" + let eft = EntityFieldType "Text" Lazy True False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing + let parseResult = parseOnly parseEntityField sampleEntityField + parseResult `shouldBe` (Right ef) + + -- describe "parseModelsFile" + -- describe "parseQuasiQuotersFile" + +main :: IO () +main = hspec spec