Fix Category bug purescript#158

paf31 · paf31 · commit e7d219edf239 · 2014-02-02T15:18:53.000-08:00
diff --git a/examples/passing/Category.purs b/examples/passing/Category.purs
@@ -0,0 +1,15 @@
+module Category where
+
+class Category c where
+  id :: forall x. c x x
+  (<|) :: forall x y z. c y z -> c x y -> c x z
+
+instance Category (->) where
+  id = Prelude.id
+  (<|) = Prelude.(<|)
+
+module Main where
+
+import Category
+  
+main = Trace.trace (id "Done")
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
@@ -3,8 +3,8 @@ module Prelude where
   foreign import data String :: *
   foreign import data Number :: *
   foreign import data Boolean :: *
-  foreign import data [] :: * -> *
-  foreign import data (->) :: * -> * -> *
+  foreign import data Array :: * -> *
+  foreign import data Function :: * -> * -> *
 
   id :: forall a. a -> a
   id = \x -> x
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
@@ -239,9 +239,6 @@ natural = PT.natural tokenParser
 properName :: P.Parsec String u ProperName
 properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
 
-properNameOrExternalType :: P.Parsec String u ProperName
-properNameOrExternalType = P.try properName <|> (ProperName <$> (P.try (lexeme $ P.string "[]") <|> (lexeme $ P.string "(->)")))
-
 -- |
 -- Parse a qualified name, i.e. M.name or just name
 --
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -64,7 +64,7 @@ parseValueDeclaration =
 
 parseExternDeclaration :: P.Parsec String ParseState Declaration
 parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
-   (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properNameOrExternalType)
+   (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
                              <*> (lexeme (indented *> P.string "::") *> parseKind)
    <|> do ident <- parseNonReservedIdent
           js <- P.optionMaybe (parseJSLiteral <$> stringLiteral)
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -33,6 +33,7 @@ typeLiterals = mkPattern match
   where
   match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"
   match (TypeVar var) = Just var
+  match (TypeApp arr ty) | arr == tyArray = Just $ "[" ++ prettyPrintType ty ++ "]"
   match (TypeConstructor ctor) = Just $ show ctor
   match (TUnknown (TypedUnknown (Unknown u))) = Just $ 'u' : show u
   match (Skolem s) = Just $ 's' : show s
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -922,7 +922,8 @@ checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionA
 -- Check the type of a function application
 --
 checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value
-checkFunctionApplication' fn (TypeApp (TypeApp t argTy) retTy) arg ret | t == tyFunction = do
+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
+  tyFunction' ?= tyFunction
   arg' <- check arg argTy
   _ <- subsumes Nothing retTy ret
   return $ App fn arg'
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
@@ -77,7 +77,7 @@ data Type
 -- Type constructor for functions
 --
 tyFunction :: Type
-tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "(->)")
+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Function")
 
 -- |
 -- Type constructor for strings
@@ -101,7 +101,7 @@ tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelu
 -- Type constructor for arrays
 --
 tyArray :: Type
-tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "[]")
+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Array")
 
 -- |
 -- Smart constructor for function types
