fix literal parser and add tests

src/Error/TypeError.hs

@@ -36,4 +36,4 @@ instance Show TypeError where
   show (Dereff n _t)             = "Could not dereference the function " ++ n ++ " with type " ++ show _t ++ ". Maybe you forgot to give it arguments."
   show (Uninitialized n)         = "Incomplete initialization of Board " ++ quote n
   show (SigBadFeq n sig f)       = quote (n ++ " : " ++ show sig) ++ " cannot be defined with the function equation\n\t" ++ show f
-  show (InputMismatch act xp e)  = "Got type " ++ show act ++ " but expected type " ++ show xp ++ " from input:\n\t" ++ show e
+  show (InputMismatch act xp e)  = "Got type " ++ show act ++ ", but expected type " ++ show xp ++ " from input:\n\t" ++ show e

src/Language/Types.hs

@@ -94,13 +94,10 @@ boardt = Plain boardxt
 boardxt :: Xtype
 boardxt = bnestx Board
 
+-- | Xtype smart constructor for Input
 inputxt :: Xtype
 inputxt = bnestx Input
 
--- | Nest a Btype as a Type
-p :: Btype -> Type
-p b = Plain $ X b S.empty
-
 instance Show Xtype where
   show (X b xs) | S.null xs = show b
                 | otherwise =

src/Parser/Parser.hs

@@ -196,13 +196,18 @@ gameIdentifier = capIdentifier
 capIdentifier :: ParsecT String u Identity [Char]
 capIdentifier = lookAhead upper *> identifier
 
+-- | Comma separated values, 2 or more
+commaSep2 :: ParsecT String u Identity a -> ParsecT String u Identity [a]
+commaSep2 p = (:) <$> (lexeme p <* lexeme comma) <*> commaSep1 p
+
 -- | Comma separated values, 1 or more
 commaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]
 commaSep1 = P.commaSep1 lexer
 
 -- | 0 or more comma separated values
-commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]
-commaSep = P.commaSep lexer
+-- unused, but possibly useful
+--commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]
+--commaSep = P.commaSep lexer
 
 -- | Reserved ops
 reservedOp :: String -> ParsecT String u Identity ()
@@ -227,7 +232,9 @@ literal =
   <|>
   S <$> capIdentifier
   <|>
-  Tuple <$> parens ((:) <$> (lexeme literal <* lexeme comma) <*> commaSep literal)
+  (try $ parens (literal <* notFollowedBy comma)) -- parenthesized literal
+  <|>
+  Tuple <$> parens (commaSep2 literal)
 
 -- | Atomic expression, under an annotation
 atom :: Parser (Expr SourcePos)

test/ParserTests.hs

@@ -21,6 +21,10 @@ checkAllParse prd pr = all (prd . parseAll pr "")
 checkAllParseFail :: Foldable t => Parser a -> t String -> Bool
 checkAllParseFail = checkAllParse isLeft
 
+-- | Checks that all parse results are successes
+checkAllParsePass :: Foldable t => Parser a -> t String -> Bool
+checkAllParsePass = checkAllParse isRight
+
 --
 -- exported tests for the Parser
 --
@@ -43,6 +47,8 @@ parserTests = TestList [
   testTypeExtLimitation2, -- todo: remove when this becomes a type error
   testIdentifiersMustBeLower,
   testNestedExprInWhileOkay,
+  testIllFormedLiteral,
+  testWellFormedLiteral,
   testRejectReservedNameSymbol,
   testMisnamedDefIsParseError1,
   testMisnamedDefIsParseError2,
@@ -628,13 +634,30 @@ testIdentifiersMustBeLower = TestCase (
   False
   (isRight $ parseAll (many decl) "" "F:Int\nF=5\nF2:Int->Int\nF2(x)=x"))
 
--- | Inputs should be okay where a normal Input would be
 testNestedExprInWhileOkay :: Test
 testNestedExprInWhileOkay = TestCase (
   assertEqual "Test that unparenthesized nested expressions are allowed in while"
   True
   (isRight $ parseAll expr "" "while x < 10 do x + 1"))
 
+testWellFormedLiteral :: Test
+testWellFormedLiteral = TestCase (
+  assertEqual "Test that well-formed literals parse"
+  True $
+  checkAllParsePass literal lits)
+     where
+        lits = ["1", "True", "False", "-1", "+1", "A", "(((40, 2), Nested, Tuple), 0)",
+                "(Parenthesized)", "       (Whitespace      ,     100    )"]
+
+testIllFormedLiteral :: Test
+testIllFormedLiteral = TestCase (
+  assertEqual "Test that ill-formed literals do not parse"
+  True $
+  checkAllParseFail literal lits)
+     where
+        lits = ["1 +", "1 * 1", "input", "let x = 1 in while x < 10 do x + 1", "1,1", "(1,)",
+                "(1,,1)", "()", "(,1,2)"]
+
 -- | Tests that reserved names are not valid symbols
 testRejectReservedNameSymbol :: Test
 testRejectReservedNameSymbol = TestCase (