tests and fixes for identifier name parsing

Nix/Parser/Library.hs

@@ -8,6 +8,7 @@ import           Control.Applicative
 
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Data.Functor.Identity
 import           Data.Text as T hiding (map)
 import           Data.Text.IO as T
 import           Text.Parsec as X hiding ((<|>), many, optional)
@@ -16,16 +17,16 @@ import           Text.Parsec.Text as X
 import qualified Text.Parsec.Token as P
 import           Text.PrettyPrint.ANSI.Leijen as X (Doc, text)
 
-lexer :: Stream s m Char => P.GenTokenParser s u m
+lexer :: P.GenTokenParser Text () Identity
 lexer = P.makeTokenParser P.LanguageDef
     { P.commentStart    = "/*"
     , P.commentEnd      = "*/"
     , P.commentLine     = "#"
     , P.nestedComments  = True
-    , P.identStart      = letter <|> char '_'
-    , P.identLetter     = alphaNum <|> oneOf "_"
-    , P.opStart         = oneOf ":!#$%&*+./<=>?@\\^|-~"
-    , P.opLetter        = oneOf "@"
+    , P.identStart      = identStart
+    , P.identLetter     = identLetter
+    , P.opStart         = opStart
+    , P.opLetter        = opLetter
     , P.reservedNames   = reservedNames
     , P.reservedOpNames = []
     , P.caseSensitive   = True
@@ -82,9 +83,9 @@ import qualified Data.HashSet as HashSet
 
 identStyle :: IdentifierStyle Parser
 identStyle = IdentifierStyle
-  { _styleName = "nix"
-  , _styleStart = letter <|> char '_'
-  , _styleLetter = alphaNum <|> oneOf "_."
+  { _styleName = "nix identifier"
+  , _styleStart = identStart
+  , _styleLetter = identLetter
   , _styleReserved = HashSet.fromList reservedNames
   , _styleHighlight = Identifier
   , _styleReservedHighlight = ReservedIdentifier
@@ -97,7 +98,8 @@ reserved :: String -> Parser Text
 reserved n = pack n <$ reserve identStyle n
 
 reservedOp :: String -> Parser Text
-reservedOp = reserved
+reservedOp o = token $ try $ pack o <$
+  highlight ReservedOperator (string o) <* (notFollowedBy opLetter <?> "end of " ++ o)
 
 -----------------------------------------------------------
 -- White space & symbols
@@ -155,6 +157,18 @@ parseFromString p = parseString p (Directed "<string>" 0 0 0 0)
 
 #endif
 
+opStart :: Parser Char
+opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
+
+opLetter :: Parser Char
+opLetter = oneOf "@"
+
+identStart :: Parser Char
+identStart = letter <|> char '_'
+
+identLetter :: Parser Char
+identLetter = alphaNum <|> oneOf "_'-"
+
 reservedNames :: [String]
 reservedNames =
     [ "let", "in"

tests/ParserTests.hs

@@ -40,6 +40,18 @@ case_simple_let = assertParseString "let a = 4; in a" $ Fix (NLet binds asym) wh
   binds = [(asym, Fix (NConstant (NInt 4)))]
   asym = Fix (NConstant (NSym "a"))
 
+case_identifier_special_chars :: Assertion
+case_identifier_special_chars = do
+  assertParseString "_a" $ Fix (NConstant (NSym "_a"))
+  assertParseString "a_b" $ Fix (NConstant (NSym "a_b"))
+  assertParseString "a'b" $ Fix (NConstant (NSym "a'b"))
+  assertParseString "a''b" $ Fix (NConstant (NSym "a''b"))
+  assertParseString "a-b" $ Fix (NConstant (NSym "a-b"))
+  assertParseString "a--b" $ Fix (NConstant (NSym "a--b"))
+  assertParseString "a12a" $ Fix (NConstant (NSym "a12a"))
+  assertParseFail ".a"
+  assertParseFail "'a"
+
 tests :: TestTree
 tests = $testGroupGenerator
 
@@ -48,3 +60,8 @@ assertParseString :: String -> NExpr -> Assertion
 assertParseString str expected = case parseNixString str of
   Success actual -> assertEqual ("When parsing " ++ str) expected actual
   Failure err    -> assertFailure $ "Unexpected error parsing `" ++ str ++ "':\n" ++ show err
+
+assertParseFail :: String -> Assertion
+assertParseFail str = case parseNixString str of
+  Failure _ -> return ()
+  Success r -> assertFailure $ "Unexpected success parsing `" ++ str ++ ":\nParsed value:" ++ show r