parse schema with path equations #6

statebox · Sep 17, 2018 · 290ae3d · 290ae3d
1 parent bc26402
commit 290ae3d
Show file tree

Hide file tree

Showing 4 changed files with 24 additions and 8 deletions.
diff --git a/src/Language/Parser/Generator/Generator.hs b/src/Language/Parser/Generator/Generator.hs
@@ -65,3 +65,6 @@ schemaPathGen = oneof
  , SchemaPathDotted <$> schemaPathGen <*> identifierGen
  , SchemaPathParen <$> identifierGen <*> schemaPathGen
  ]
+
+schemaPathEqnSigGen :: Gen SchemaPathEqnSig
+schemaPathEqnSigGen = SchemaPathEqnSig <$> schemaPathGen <*> schemaPathGen
diff --git a/src/Language/Parser/Schema.hs b/src/Language/Parser/Schema.hs
@@ -56,7 +56,7 @@ schemaLiteralSectionParser = do
  (fromMaybe [] maybeImports)
  (fromMaybe [] maybeEntities)
  (fromMaybe [] maybeForeignKeys)
- []
+ (fromMaybe [] maybePathEquations)
  []
  []
 

diff --git a/src/Language/Parser/Types.hs b/src/Language/Parser/Types.hs
@@ -176,6 +176,9 @@ type SchemaForeignId = String
 data SchemaPathEqnSig = SchemaPathEqnSig SchemaPath SchemaPath
  deriving (Eq)
 
+instance Show SchemaPathEqnSig where
+ show (SchemaPathEqnSig schemaPathLeft schemaPathRight) = (show schemaPathLeft) ++ " = " ++ (show schemaPathRight)
+
 data SchemaPath
  = SchemaPathArrowId SchemaArrowId
  | SchemaPathDotted SchemaPath SchemaArrowId

diff --git a/test/Parser/SchemaSpec.hs b/test/Parser/SchemaSpec.hs
@@ -49,22 +49,28 @@ spec = do
  forAll (listOf identifierGen) $
  \identifiers -> parse schemaLiteralSectionParser "" ("entities " ++ (unwords $ identifiers))
  == Right (SchemaLiteralSection [] identifiers [] [] [] [])
- specify "parses correctly a SchemaLiteralSection with foreign keys" $
+ specify "parses correctly a SchemaLiteralSection with foreign keys" $ withMaxSuccess 30 $
  forAll (listOf schemaForeignSigGen) $
  \schemaForeignSigs -> parse schemaLiteralSectionParser "" ("foreign_keys " ++ (unwords $ map show schemaForeignSigs))
  == Right (SchemaLiteralSection [] [] schemaForeignSigs [] [] [])
- specify "parses correctly a SchemaLiteralSection with every piece" $
- forAll ((\a b c -> (a, b, c)) <$> listOf typesideImportGen <*> listOf identifierGen <*> listOf schemaForeignSigGen) $
- \(typesideImports, identifiers, schemaForeignSigs) ->
+ specify "parses correctly a SchemaLiteralSection with path equations" $ withMaxSuccess 30 $
+ forAll (listOf schemaPathEqnSigGen) $
+ \schemaPathEqnSigs -> parse schemaLiteralSectionParser "" ("path_equations" ++ (unwords $ map show schemaPathEqnSigs))
+ == Right (SchemaLiteralSection [] [] [] schemaPathEqnSigs [] [])
+ specify "parses correctly a SchemaLiteralSection with every piece" $ withMaxSuccess 30 $
+ forAll ((\a b c d -> (a, b, c, d)) <$> listOf typesideImportGen <*> listOf identifierGen <*> listOf schemaForeignSigGen <*> listOf schemaPathEqnSigGen) $
+ \(typesideImports, identifiers, schemaForeignSigs, schemaPathEqnSigs) ->
  parse schemaLiteralSectionParser ""
  ( "imports "
  ++ (unwords $ map show typesideImports)
  ++ " entities "
  ++ (unwords $ identifiers)
  ++ " foreign_keys "
  ++ (unwords $ map show schemaForeignSigs)
+ ++ " path_equations "
+ ++ (unwords $ map show schemaPathEqnSigs)
  )
- == Right (SchemaLiteralSection typesideImports identifiers schemaForeignSigs [] [] [])
+ == Right (SchemaLiteralSection typesideImports identifiers schemaForeignSigs schemaPathEqnSigs [] [])
 
  describe "schemaForeignSigParser" $ do
  specify "parses correctly a SchemaForeignSig" $
@@ -73,8 +79,12 @@ spec = do
  parse schemaForeignSigParser "" ((unwords $ toList schemaForeignIds) ++ " : " ++ originSchemaEntityId ++ " -> " ++ targetSchemaEntityId)
  == Right (SchemaForeignSig schemaForeignIds originSchemaEntityId targetSchemaEntityId)
 
- -- describe "schemaPathEqnSigParser" $ do
- -- specify "parses correctly a SchemaPathEqnSig" $
+ describe "schemaPathEqnSigParser" $ do
+ specify "parses correctly a SchemaPathEqnSig" $
+ forAll ((\a b -> (a, b)) <$> schemaPathGen <*> schemaPathGen) $
+ \(schemaPathLeft, schemaPathRight) ->
+ parse schemaPathEqnSigParser "" ((show schemaPathLeft) ++ " = " ++ (show schemaPathRight)) ==
+ Right (SchemaPathEqnSig schemaPathLeft schemaPathRight)
 
  describe "schemaPathParser" $ do
  specify "parses correctly a SchemaPathArrowId schemaPath" $