Merge pull request purescript#2167 from purescript/primed-types

garyb · garyb · commit bbd5a83b874e · 2016-05-28T12:16:52.000+01:00
Allow use of prime symbol in type names.
diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs
@@ -0,0 +1,20 @@
+module Main (T, T', T'', T''', main) where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+data T a = T
+type T' = T Unit
+
+data T'' = TP
+
+foreign import data T''' ∷ *
+
+instance eqT ∷ Eq T'' where
+  eq _ _ = true
+
+type A' a b = b → a
+
+infixr 4 type A' as ↫
+
+main = log "Done"
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
@@ -16,9 +16,18 @@ import Language.PureScript.Parser.State
 
 import qualified Text.Parsec as P
 
+-- |
+-- Parse a general proper name.
+--
 properName :: TokenParser (ProperName a)
 properName = ProperName <$> uname
 
+-- |
+-- Parse a proper name for a type.
+--
+typeName :: TokenParser (ProperName 'TypeName)
+typeName = ProperName <$> tyname
+
 -- |
 -- Parse a module name
 --
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -66,7 +66,7 @@ kindedIdent = (, Nothing) <$> identifier
 parseDataDeclaration :: TokenParser Declaration
 parseDataDeclaration = do
   dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
-  name <- indented *> properName
+  name <- indented *> typeName
   tyArgs <- many (indented *> kindedIdent)
   ctors <- P.option [] $ do
     indented *> equals
@@ -80,7 +80,7 @@ parseTypeDeclaration =
 
 parseTypeSynonymDeclaration :: TokenParser Declaration
 parseTypeSynonymDeclaration =
-  TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
+  TypeSynonymDeclaration <$> (reserved "type" *> indented *> typeName)
                          <*> many (indented *> kindedIdent)
                          <*> (indented *> equals *> noWildcards parsePolyType)
 
@@ -108,7 +108,7 @@ parseValueDeclaration = do
 
 parseExternDeclaration :: TokenParser Declaration
 parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>
-   (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)
+   (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName)
                           <*> (indented *> doubleColon *> parseKind)
    <|> (do ident <- parseIdent
            ty <- indented *> doubleColon *> noWildcards parsePolyType
@@ -132,7 +132,7 @@ parseFixityDeclaration = do
   where
   typeFixity fixity =
     TypeFixity fixity
-      <$> (reserved "type" *> parseQualified properName)
+      <$> (reserved "type" *> parseQualified typeName)
       <*> (reserved "as" *> parseOperator)
   valueFixity fixity =
     ValueFixity fixity
@@ -169,7 +169,7 @@ parseDeclarationRef =
     <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator))
   where
   parseTypeRef = do
-    name <- properName
+    name <- typeName
     dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
     return $ TypeRef name (fromMaybe (Just []) dctors)
 
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
@@ -41,8 +41,8 @@ module Language.PureScript.Parser.Lexer
   , commaSep1
   , lname
   , qualifier
+  , tyname
   , uname
-  , uname'
   , mname
   , reserved
   , symbol
@@ -213,8 +213,9 @@ parseToken = P.choice
   , P.try $ P.char '_'    *> P.notFollowedBy identLetter *> pure Underscore
   , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter)
   , LName         <$> parseLName
-  , do uName <- parseUName
-       (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
+  , parseUName >>= \uName ->
+      (guard (validModuleName uName) >> Qualifier uName <$ P.char '.')
+        <|> pure (UName uName)
   , Symbol        <$> parseSymbol
   , CharLiteral   <$> parseCharLiteral
   , StringLiteral <$> parseStringLiteral
@@ -226,7 +227,7 @@ parseToken = P.choice
   parseLName = (:) <$> identStart <*> P.many identLetter
 
   parseUName :: P.Parsec String u String
-  parseUName = (:) <$> P.upper <*> P.many uidentLetter
+  parseUName = (:) <$> P.upper <*> P.many identLetter
 
   parseSymbol :: P.Parsec String u String
   parseSymbol = P.many1 symbolChar
@@ -237,9 +238,6 @@ parseToken = P.choice
   identLetter :: P.Parsec String u Char
   identLetter = P.alphaNum <|> P.oneOf "_'"
 
-  uidentLetter :: P.Parsec String u Char
-  uidentLetter = P.alphaNum <|> P.char '_'
-
   symbolChar :: P.Parsec String u Char
   symbolChar = P.satisfy isSymbolChar
 
@@ -430,6 +428,12 @@ reserved s = token go P.<?> show s
 
 uname :: TokenParser String
 uname = token go P.<?> "proper name"
+  where
+  go (UName s) | validUName s = Just s
+  go _ = Nothing
+
+tyname :: TokenParser String
+tyname = token go P.<?> "type name"
   where
   go (UName s) = Just s
   go _ = Nothing
@@ -440,12 +444,6 @@ mname = token go P.<?> "module name"
   go (UName s) | validModuleName s = Just s
   go _ = Nothing
 
-uname' :: String -> TokenParser ()
-uname' s = token go P.<?> show s
-  where
-  go (UName s') | s == s' = Just ()
-  go _ = Nothing
-
 symbol :: TokenParser String
 symbol = token go P.<?> "symbol"
   where
@@ -496,6 +494,9 @@ identifier = token go P.<?> "identifier"
 validModuleName :: String -> Bool
 validModuleName s = '_' `notElem` s
 
+validUName :: String -> Bool
+validUName s = '\'' `notElem` s
+
 -- |
 -- A list of purescript reserved identifiers
 --
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
@@ -40,7 +40,7 @@ parseTypeVariable = do
   return $ TypeVar ident
 
 parseTypeConstructor :: TokenParser Type
-parseTypeConstructor = TypeConstructor <$> parseQualified properName
+parseTypeConstructor = TypeConstructor <$> parseQualified typeName
 
 parseForAll :: TokenParser Type
 parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot)
