summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-08 00:14:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-08 00:14:00 (GMT)
commit8f515100470cc96ad45ed3473d6d9a257929326a (patch)
tree4c31015b6deb18944fda1d2f9b716994b5ab0fce
parentae4c5796f5f328515e762604ac14e23b8f39ab81 (diff)
version 0.3.100.3.10
-rw-r--r--docgen/Main.hs155
-rw-r--r--libraries/prelude/prelude.purs109
-rw-r--r--purescript.cabal18
-rw-r--r--src/Language/PureScript/Names.hs2
-rw-r--r--src/Language/PureScript/Parser/Common.hs176
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs11
-rw-r--r--src/Language/PureScript/Parser/JS.hs167
-rw-r--r--src/Language/PureScript/Parser/Types.hs5
-rw-r--r--src/Language/PureScript/Parser/Values.hs4
-rw-r--r--src/Language/PureScript/Pretty/Types.hs22
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs14
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs18
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs27
-rw-r--r--src/Language/PureScript/Types.hs20
16 files changed, 415 insertions, 341 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
new file mode 100644
index 0000000..544f503
--- /dev/null
+++ b/docgen/Main.hs
@@ -0,0 +1,155 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Main where
+
+import qualified Language.PureScript as P
+import System.Console.CmdTheLine
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Writer
+import System.Exit (exitSuccess, exitFailure)
+import qualified System.IO.UTF8 as U
+import qualified Paths_purescript as Paths
+import Data.Version (showVersion)
+import Data.List
+import Data.Function (on)
+
+docgen :: FilePath -> IO ()
+docgen input = do
+ text <- U.readFile input
+ case P.runIndentParser input P.parseModules text of
+ Left err -> do
+ U.print err
+ exitFailure
+ Right ms -> do
+ U.putStrLn . runDocs $ renderModules ms
+ exitSuccess
+
+type Docs = Writer [String] ()
+
+runDocs :: Docs -> String
+runDocs = unlines . execWriter
+
+spacer :: Docs
+spacer = tell [""]
+
+headerLevel :: Int -> String -> Docs
+headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
+
+atIndent :: Int -> String -> Docs
+atIndent indent text =
+ let ls = lines text in
+ forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
+
+renderModules :: [P.Module] -> Docs
+renderModules ms = do
+ headerLevel 1 "Module Documentation"
+ mapM_ renderModule ms
+
+renderModule :: P.Module -> Docs
+renderModule (P.Module (P.ProperName moduleName) ds) = do
+ headerLevel 2 $ "Module " ++ moduleName
+ spacer
+ headerLevel 3 "Types"
+ spacer
+ renderTopLevel (filter isTypeDeclaration ds)
+ spacer
+ headerLevel 3 "Type Classes"
+ spacer
+ renderTopLevel (filter isTypeClassDeclaration ds)
+ spacer
+ headerLevel 3 "Type Class Instances"
+ spacer
+ renderTopLevel (filter isTypeInstanceDeclaration ds)
+ spacer
+ headerLevel 3 "Values"
+ spacer
+ renderTopLevel (filter isValueDeclaration ds)
+ spacer
+
+renderTopLevel :: [P.Declaration] -> Docs
+renderTopLevel decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
+ renderDeclaration 4 decl
+ spacer
+
+renderDeclaration :: Int -> P.Declaration -> Docs
+renderDeclaration n (P.TypeDeclaration ident ty) =
+ atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
+renderDeclaration n (P.ExternDeclaration _ ident _ ty) =
+ atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
+renderDeclaration n (P.DataDeclaration name args ctors) = do
+ let typeName = P.runProperName name ++ " " ++ intercalate " " args
+ atIndent n $ "data " ++ typeName ++ " where"
+ forM_ ctors $ \(ctor, ty) -> do
+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ maybe "" ((++ " -> ") . P.prettyPrintType) ty ++ typeName
+renderDeclaration n (P.ExternDataDeclaration name kind) =
+ atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
+renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
+ let typeName = P.runProperName name ++ " " ++ intercalate " " args
+ atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
+renderDeclaration n (P.TypeClassDeclaration name arg ds) = do
+ atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where"
+ mapM_ (renderDeclaration (n + 2)) ds
+renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do
+ let constraintsText = case constraints of
+ [] -> ""
+ cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => "
+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty
+renderDeclaration _ _ = return ()
+
+getName :: P.Declaration -> String
+getName (P.TypeDeclaration ident _) = show ident
+getName (P.ExternDeclaration _ ident _ _) = show ident
+getName (P.DataDeclaration name _ _) = P.runProperName name
+getName (P.ExternDataDeclaration name _) = P.runProperName name
+getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
+getName (P.TypeClassDeclaration name _ _) = P.runProperName name
+getName (P.TypeInstanceDeclaration _ name _ _) = show name
+getName _ = error "Invalid argument to getName"
+
+isValueDeclaration :: P.Declaration -> Bool
+isValueDeclaration (P.TypeDeclaration _ _) = True
+isValueDeclaration (P.ExternDeclaration _ _ _ _) = True
+isValueDeclaration _ = False
+
+isTypeDeclaration :: P.Declaration -> Bool
+isTypeDeclaration (P.DataDeclaration _ _ _) = True
+isTypeDeclaration (P.ExternDataDeclaration _ _) = True
+isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True
+isTypeDeclaration _ = False
+
+isTypeClassDeclaration :: P.Declaration -> Bool
+isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True
+isTypeClassDeclaration _ = False
+
+isTypeInstanceDeclaration :: P.Declaration -> Bool
+isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True
+isTypeInstanceDeclaration _ = False
+
+inputFile :: Term FilePath
+inputFile = value $ pos 0 "input.ps" $ posInfo { posDoc = "The input .ps file" }
+
+term :: Term (IO ())
+term = docgen <$> inputFile
+
+termInfo :: TermInfo
+termInfo = defTI
+ { termName = "docgen"
+ , version = showVersion $ Paths.version
+ , termDoc = "Generate Markdown documentation from PureScript extern files"
+ }
+
+main :: IO ()
+main = run (term, termInfo)
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index 42dfa4c..fec2078 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -1,19 +1,13 @@
module Prelude where
- foreign import data String :: *
- foreign import data Number :: *
- foreign import data Boolean :: *
- foreign import data Array :: * -> *
- foreign import data Function :: * -> * -> *
-
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b
- konst :: forall a b. a -> b -> a
- konst a _ = a
+ const :: forall a b. a -> b -> a
+ const a _ = a
- infixr 5 >>>
- infixr 5 <<<
+ infixr 9 >>>
+ infixr 9 <<<
class Category a where
id :: forall t. a t t
@@ -25,8 +19,8 @@ module Prelude where
(<<<) f g x = f (g x)
(>>>) f g x = g (f x)
- infixr 1000 $
- infixl 1000 #
+ infixr 0 $
+ infixl 0 #
($) :: forall a b. (a -> b) -> a -> b
($) f x = f x
@@ -81,23 +75,25 @@ module Prelude where
empty :: forall a. f a
(<|>) :: forall a. f a -> f a -> f a
+ infixl 1 >>=
+
class Monad m where
- ret :: forall a. a -> m a
+ return :: forall a. a -> m a
(>>=) :: forall a b. m a -> (a -> m b) -> m b
instance (Monad m) => Applicative m where
- pure = ret
+ pure = return
(<*>) f a = do
f' <- f
a' <- a
- ret (f' a')
+ return (f' a')
- infixl 5 *
- infixl 5 /
- infixl 5 %
+ infixl 7 *
+ infixl 7 /
+ infixl 7 %
- infixl 7 -
- infixl 7 +
+ infixl 6 -
+ infixl 6 +
class Num a where
(+) :: a -> a -> a
@@ -149,8 +145,8 @@ module Prelude where
(%) = numMod
negate = numNegate
- infixl 9 ==
- infixl 9 /=
+ infixl 4 ==
+ infixl 4 /=
class Eq a where
(==) :: a -> a -> Boolean
@@ -205,10 +201,10 @@ module Prelude where
(==) _ _ = false
(/=) xs ys = not (xs == ys)
- infixl 3 <
- infixl 3 >
- infixl 3 <=
- infixl 3 >=
+ infixl 4 <
+ infixl 4 >
+ infixl 4 <=
+ infixl 4 >=
class Ord a where
(<) :: a -> a -> Boolean
@@ -308,7 +304,7 @@ module Prelude where
zshr = numZshr
complement = numComplement
- infixl 4 !!
+ infixl 8 !!
foreign import (!!) "function $bang$bang(xs) {\
\ return function(n) {\
@@ -316,8 +312,8 @@ module Prelude where
\ };\
\}" :: forall a. [a] -> Number -> a
- infixr 11 ||
- infixr 11 &&
+ infixr 2 ||
+ infixr 3 &&
class BoolLike b where
(&&) :: b -> b -> b
@@ -345,7 +341,7 @@ module Prelude where
(||) = boolOr
not = boolNot
- infixr 6 ++
+ infixr 5 ++
foreign import (++) "function $plus$plus(s1) {\
\ return function(s2) {\
@@ -362,7 +358,7 @@ module Monoid where
class Monoid m where
mempty :: m
(<>) :: m -> m -> m
-
+
instance Monoid String where
mempty = ""
(<>) = (++)
@@ -377,18 +373,18 @@ module Monad where
import Arrays
replicateM :: forall m a. (Monad m) => Number -> m a -> m [a]
- replicateM 0 _ = ret []
+ replicateM 0 _ = return []
replicateM n m = do
a <- m
as <- replicateM (n - 1) m
- ret (a : as)
+ return (a : as)
mapM :: forall m a b. (Monad m) => (a -> m b) -> [a] -> m [b]
- mapM _ [] = ret []
+ mapM _ [] = return []
mapM f (a:as) = do
b <- f a
bs <- mapM f as
- ret (b : bs)
+ return (b : bs)
infixr 1 >=>
infixr 1 <=<
@@ -397,16 +393,16 @@ module Monad where
(>=>) f g a = do
b <- f a
g b
-
- (<=<) :: forall m a b c. (Monad m) => (b -> m c) -> (a -> m b) -> a -> m c
+
+ (<=<) :: forall m a b c. (Monad m) => (b -> m c) -> (a -> m b) -> a -> m c
(<=<) = flip (>=>)
sequence :: forall m a. (Monad m) => [m a] -> m [a]
- sequence [] = ret []
+ sequence [] = return []
sequence (m:ms) = do
a <- m
as <- sequence ms
- ret (a : as)
+ return (a : as)
join :: forall m a. (Monad m) => m (m a) -> m a
join mm = do
@@ -414,12 +410,12 @@ module Monad where
m
foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
- foldM _ a [] = ret a
+ foldM _ a [] = return a
foldM f a (b:bs) = f a b >>= \a' -> foldM f a' bs
when :: forall m. (Monad m) => Boolean -> m {} -> m {}
when true m = m
- when false _ = ret {}
+ when false _ = return {}
module Maybe where
@@ -435,7 +431,7 @@ module Maybe where
fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
instance Prelude.Monad Maybe where
- ret = Just
+ return = Just
(>>=) m f = maybe Nothing f m
module Either where
@@ -447,7 +443,7 @@ module Either where
either _ g (Right b) = g b
instance Prelude.Monad (Either e) where
- ret = Right
+ return = Right
(>>=) = either (\e _ -> Left e) (\a f -> f a)
module Arrays where
@@ -604,35 +600,38 @@ module Arrays where
show (x:xs) = show x ++ " : " ++ show xs
instance Prelude.Monad [] where
- ret = singleton
+ return = singleton
(>>=) = concatMap
instance Prelude.Alternative [] where
empty = []
(<|>) = concat
-module Tuple where
+module Tuples where
import Prelude
import Arrays
- type Tuple a b = { fst :: a, snd :: b }
+ data Tuple a b = Tuple { fst :: a, snd :: b }
+
+ instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where
+ show (Tuple { fst = a, snd = b }) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
- curry f a b = f { fst: a, snd: b }
+ curry f a b = f (tuple a b)
uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
- uncurry f t = f t.fst t.snd
+ uncurry f (Tuple t) = f t.fst t.snd
tuple :: forall a b. a -> b -> Tuple a b
- tuple = curry (\t -> t)
+ tuple a b = Tuple { fst: a, snd: b }
zip :: forall a b. [a] -> [b] -> [Tuple a b]
zip = zipWith tuple
unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
- unzip (t:ts) = case unzip ts of
- { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)
+ unzip ((Tuple t):ts) = case unzip ts of
+ Tuple { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)
unzip [] = tuple [] []
module String where
@@ -886,7 +885,7 @@ module Eff where
\}" :: forall a. Pure a -> a
instance Prelude.Monad (Eff e) where
- ret = retEff
+ return = retEff
(>>=) = bindEff
foreign import untilE "function untilE(f) {\
@@ -906,7 +905,7 @@ module Eff where
\ };\
\ };\
\}" :: forall e. Eff e Boolean -> Eff e {} -> Eff e {}
-
+
foreign import forE "function forE(lo) {\
\ return function(hi) {\
\ return function(f) {\
@@ -1000,6 +999,10 @@ module IORef where
\ };\
\}" :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
+ foreign import unsafeRunIORef "function unsafeRunIORef(f) {\
+ \ return f;\
+ \}" :: forall eff a. Eff (ref :: Ref | eff) a -> Eff eff a
+
module Trace where
import Prelude
diff --git a/purescript.cabal b/purescript.cabal
index 8659aab..a3c3065 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,23 +1,23 @@
name: purescript
-version: 0.3.9
+version: 0.3.10
cabal-version: >=1.8
build-type: Simple
license: MIT
license-file: LICENSE
-copyright: (c) Phil Freeman 2013
+copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
maintainer: Phil Freeman <paf31@cantab.net>
stability: experimental
synopsis: PureScript Programming Language Compiler
description: A small compile-to-JS language with extensible records and type-safe blocks
category: Language
-author: Phil Freeman <paf31@cantab.net>
+author: Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
data-files: libraries/prelude/prelude.purs
data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any, syb -any,
- transformers -any, utf8-string -any, pattern-arrows -any, monad-unify -any
+ transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3
exposed-modules: Data.Generics.Extras
Language.PureScript
Language.PureScript.Options
@@ -49,7 +49,6 @@ library
Language.PureScript.Parser.State
Language.PureScript.Parser.Types
Language.PureScript.Parser.Values
- Language.PureScript.Parser.JS
Language.PureScript.Pretty
Language.PureScript.Pretty.Common
Language.PureScript.Pretty.JS
@@ -86,6 +85,15 @@ executable psci
other-modules:
ghc-options: -Wall -O2
+executable docgen
+ build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
+ process -any, mtl -any
+ main-is: Main.hs
+ buildable: True
+ hs-source-dirs: docgen
+ other-modules:
+ ghc-options: -Wall -O2
+
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
filepath -any, mtl -any, parsec -any, purescript -any, syb -any,
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index ecfd096..4519e53 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -52,7 +52,7 @@ instance Show ProperName where
-- |
-- Module names
--
-data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
+data ModuleName = ModuleName { runModuleName :: ProperName } deriving (Eq, Ord, Data, Typeable)
instance Show ModuleName where
show (ModuleName name) = show name
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index aefbd85..365edbd 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -27,60 +27,100 @@ import qualified Text.Parsec.Token as PT
import Language.PureScript.Names
-- |
--- A list of reserved identifiers
---
-reservedNames :: [String]
-reservedNames = [ "case"
- , "of"
- , "data"
- , "type"
- , "var"
- , "val"
- , "while"
- , "for"
- , "foreach"
- , "if"
- , "then"
- , "else"
- , "return"
- , "true"
- , "false"
- , "foreign"
- , "import"
- , "member"
- , "forall"
- , "do"
- , "until"
- , "in"
- , "break"
- , "catch"
- , "continue"
- , "debugger"
- , "default"
- , "delete"
- , "finally"
- , "function"
- , "instanceof"
- , "new"
- , "switch"
- , "this"
- , "throw"
- , "try"
- , "typeof"
- , "void"
- , "with"
- , "Number"
- , "String"
- , "Boolean"
- , "infixl"
- , "infixr"
- , "module"
- , "let"
- , "class"
- , "instance"
- , "where"
- , "null"
- , "undefined" ]
+-- A list of purescript reserved identifiers
+--
+reservedPsNames :: [String]
+reservedPsNames = [ "data"
+ , "type"
+ , "foreign"
+ , "import"
+ , "infixl"
+ , "infixr"
+ , "class"
+ , "instance"
+ , "module"
+ , "case"
+ , "of"
+ , "if"
+ , "then"
+ , "else"
+ , "do"
+ , "let"
+ , "true"
+ , "false"
+ , "until"
+
+ ]
+
+-- |
+-- A list of javascript reserved identifiers
+--
+reservedJsNames :: [String]
+reservedJsNames = [ "abstract"
+ , "boolean"
+ , "break"
+ , "byte"
+ , "case"
+ , "catch"
+ , "char"
+ , "class"
+ , "const"
+ , "continue"
+ , "debugger"
+ , "default"
+ , "delete"
+ , "do"
+ , "double"
+ , "else"
+ , "enum"
+ , "export"
+ , "extends"
+ , "final"
+ , "finally"
+ , "float"
+ , "for"
+ , "function"
+ , "goto"
+ , "if"
+ , "implements"
+ , "import"
+ , "in"
+ , "instanceof"
+ , "int"
+ , "interface"
+ , "let"
+ , "long"
+ , "native"
+ , "new"
+ , "package"
+ , "private"
+ , "protected"
+ , "public"
+ , "return"
+ , "short"
+ , "static"
+ , "super"
+ , "switch"
+ , "synchronized"
+ , "this"
+ , "throw"
+ , "throws"
+ , "transient"
+ , "try"
+ , "typeof"
+ , "var"
+ , "void"
+ , "volatile"
+ , "while"
+ , "with"
+ , "yield" ]
+
+-- |
+-- A list of reserved identifiers for types
+--
+reservedTypeNames :: [String]
+reservedTypeNames = [ "forall"
+ , "where" ]
-- |
-- A list of reserved operators
@@ -95,12 +135,6 @@ identStart :: P.Parsec String u Char
identStart = P.lower <|> P.oneOf "_"
-- |
--- Valid first characters for a proper name
---
-properNameStart :: P.Parsec String u Char
-properNameStart = P.upper
-
--- |
-- Valid identifier characters
--
identLetter :: P.Parsec String u Char
@@ -123,7 +157,7 @@ opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
--
langDef :: PT.GenLanguageDef String u Identity
langDef = PT.LanguageDef
- { PT.reservedNames = reservedNames
+ { PT.reservedNames = reservedPsNames
, PT.reservedOpNames = reservedOpNames
, PT.commentStart = "{-"
, PT.commentEnd = "-}"
@@ -230,7 +264,7 @@ natural = PT.natural tokenParser
-- Parse a proper name
--
properName :: P.Parsec String u ProperName
-properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")
-- |
-- Parse a qualified name, i.e. M.name or just name
@@ -253,20 +287,12 @@ integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
-- Parse an identifier or parenthesized operator
--
parseIdent :: P.Parsec String ParseState Ident
-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
-
-
--- |
--- Parse an identifier or parenthesized operator that is not a reserved keyword or operator
---
-parseNonReservedIdent :: P.Parsec String ParseState Ident
-parseNonReservedIdent = do
- ident <- parseIdent
- when (isReserved ident) $ P.unexpected $ "reserved identifier " ++ show ident
- return ident
+parseIdent = parseIdent' <|> (Op <$> parens operator)
where
- isReserved (Ident ident) = ident `elem` reservedNames
- isReserved (Op op) = op `elem` reservedOpNames
+ parseIdent' :: P.Parsec String ParseState Ident
+ parseIdent' = do
+ ident <- identifier
+ return $ if (ident `elem` reservedJsNames) then (Escaped $ "$" ++ ident) else (Ident ident)
-- |
-- Parse a token inside square brackets
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 17d2ad9..79f4248 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -31,7 +31,6 @@ import Language.PureScript.Declarations
import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
-import Language.PureScript.Parser.JS
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Values
@@ -46,7 +45,7 @@ parseDataDeclaration = do
parseTypeDeclaration :: P.Parsec String ParseState Declaration
parseTypeDeclaration =
- TypeDeclaration <$> P.try (parseNonReservedIdent <* lexeme (indented *> P.string "::"))
+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
<*> parsePolyType
parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
@@ -57,7 +56,7 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
- ValueDeclaration <$> parseNonReservedIdent
+ ValueDeclaration <$> parseIdent
<*> P.many parseBinderNoParens
<*> P.optionMaybe parseGuard
<*> ((lexeme (indented *> P.char '=')) *> parseValue)
@@ -66,12 +65,10 @@ parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (lexeme (indented *> P.string "::") *> parseKind)
- <|> do ident <- parseNonReservedIdent
- js <- P.optionMaybe (parseJSLiteral <$> stringLiteral)
+ <|> do ident <- parseIdent
+ js <- P.optionMaybe (JSRaw <$> stringLiteral)
ty <- (lexeme (indented *> P.string "::") *> parsePolyType)
return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)
-parseJSLiteral :: String -> JS
-parseJSLiteral s = either (const $ JSRaw s) id $ P.runParser parseJS () "Javascript" s
parseAssociativity :: P.Parsec String ParseState Associativity
parseAssociativity =
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
deleted file mode 100644
index adf6dde..0000000
--- a/src/Language/PureScript/Parser/JS.hs
+++ /dev/null
@@ -1,167 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.JS
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- A parser for a small fragment of Javascript
---
------------------------------------------------------------------------------
-
-module Language.PureScript.Parser.JS (
- parseJS
-) where
-
-import Language.PureScript.Values
-import Language.PureScript.Names
-import Language.PureScript.CodeGen.JS.AST
-import qualified Language.PureScript.Parser.Common as C
-import Control.Applicative
-import Data.Functor.Identity
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Token as P
-import qualified Text.Parsec.Expr as P
-
-booleanLiteral :: P.Parsec String u Bool
-booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
-
-parseNumericLiteral :: P.Parsec String u JS
-parseNumericLiteral = JSNumericLiteral <$> C.integerOrFloat
-
-parseStringLiteral :: P.Parsec String u JS
-parseStringLiteral = JSStringLiteral <$> C.stringLiteral
-
-parseBooleanLiteral :: P.Parsec String u JS
-parseBooleanLiteral = JSBooleanLiteral <$> booleanLiteral
-
-parseArrayLiteral :: P.Parsec String u JS
-parseArrayLiteral = JSArrayLiteral <$> P.squares C.tokenParser (P.commaSep C.tokenParser parseJS)
-
-parseObjectLiteral :: P.Parsec String u JS
-parseObjectLiteral = JSObjectLiteral <$> P.braces C.tokenParser (P.commaSep C.tokenParser parseIdentifierAndValue)
-
-parseIdentifierAndValue :: P.Parsec String u (String, JS)
-parseIdentifierAndValue = (,) <$> (C.identifier <* C.colon)
- <*> parseJS
-
-parseFunction :: P.Parsec String u JS
-parseFunction = do
- C.reserved "function"
- name <- P.optionMaybe C.identifier
- args <- P.parens C.tokenParser $ P.commaSep C.tokenParser C.identifier
- body <- parseJS
- return $ JSFunction name args body
-
-parseBlock :: P.Parsec String u JS
-parseBlock = JSBlock <$> P.braces C.tokenParser (P.many parseJS)
-
-parseVar :: P.Parsec String u JS
-parseVar = JSVar <$> C.identifier
-
-parseJSAtom :: P.Parsec String u JS
-parseJSAtom = P.choice
- [ P.try parseNumericLiteral
- , P.try parseStringLiteral
- , P.try parseBooleanLiteral
- , parseArrayLiteral
- , P.try parseObjectLiteral
- , parseFunction
- , parseBlock
- , P.try parseVar
- , parseVariableIntroduction
- , parseWhile
- , parseIf
- , parseReturn
- , P.parens C.tokenParser parseJS ]
-
-parseAccessor :: JS -> P.Parsec String u JS
-parseAccessor js = P.try $ flip JSAccessor js <$> (C.dot *> P.notFollowedBy C.opLetter *> C.identifier)
-
-parseIndexer :: JS -> P.Parsec String u JS
-parseIndexer js = P.try $ flip JSIndexer js <$> (P.squares C.tokenParser parseJS)
-
-parseConditional :: JS -> P.Parsec String u JS
-parseConditional js = P.try $ do
- _ <- C.lexeme $ P.char '?'
- tr <- parseJS
- _ <- C.lexeme $ P.char ':'
- fa <- parseJS
- return $ JSConditional js tr fa
-
-binary :: BinaryOperator -> String -> P.Assoc -> P.Operator String u Identity JS
-binary op s f = P.Infix (P.try $ C.reservedOp s >> return (JSBinary op)) f
-
-unary :: UnaryOperator -> String -> P.Operator String u Identity JS
-unary op s = P.Prefix (P.try $ C.reservedOp s >> return (JSUnary op))
-
--- |
--- Parse a simplified Javascript expression
---
-parseJS :: P.Parsec String u JS
-parseJS =
- (P.buildExpressionParser operators
- . C.buildPostfixParser postfixTable2
- $ indexersAndAccessors) P.<?> "javascript"
- where
- indexersAndAccessors = C.buildPostfixParser postfixTable1 parseJSAtom
- postfixTable1 = [ parseAccessor, parseIndexer, parseConditional, parseAssignment ]
- postfixTable2 = [ \v -> P.try $ JSApp v <$> (P.parens C.tokenParser (P.commaSep C.tokenParser parseJS)) ]
- operators = [ [ binary LessThan "<" P.AssocLeft]
- , [ binary LessThanOrEqualTo "<=" P.AssocLeft]
- , [ binary GreaterThan ">" P.AssocLeft]
- , [ binary GreaterThanOrEqualTo ">=" P.AssocLeft]
- , [ unary Not "!" ]
- , [ unary BitwiseNot "~" ]
- , [ unary Negate "-" ]
- , [ unary Positive "+" ]
- , [ binary Multiply "*" P.AssocLeft]
- , [ binary Divide "/" P.AssocLeft]
- , [ binary Modulus "%" P.AssocLeft]
- , [ binary Add "+" P.AssocLeft]
- , [ binary Subtract "-" P.AssocLeft]
- , [ binary ShiftLeft "<<" P.AssocLeft]
- , [ binary ShiftRight ">>" P.AssocLeft]
- , [ binary ZeroFillShiftRight ">>>" P.AssocLeft]
- , [ binary EqualTo "===" P.AssocLeft]
- , [ binary NotEqualTo "!==" P.AssocLeft]
- , [ binary BitwiseAnd "&" P.AssocLeft]
- , [ binary BitwiseXor "^" P.AssocLeft]
- , [ binary BitwiseOr "|" P.AssocLeft]
- , [ binary And "&&" P.AssocRight]
- , [ binary Or "||" P.AssocRight]
- ]
-
-parseVariableIntroduction :: P.Parsec String u JS
-parseVariableIntroduction = do
- C.reserved "var"
- name <- P.identifier C.tokenParser
- value <- P.optionMaybe $ do
- _ <- C.lexeme $ P.char '='
- value <- parseJS
- _ <- C.semi
- return value
- return $ JSVariableIntroduction name value
-
-parseAssignment :: JS -> P.Parsec String u JS
-parseAssignment tgt = do
- _ <- C.lexeme $ P.char '='
- value <- parseJS
- _ <- C.semi
- return $ JSAssignment tgt value
-
-parseWhile :: P.Parsec String u JS
-parseWhile = JSWhile <$> (C.reserved "while" *> P.parens C.tokenParser parseJS)
- <*> parseJS
-
-parseIf :: P.Parsec String u JS
-parseIf = JSIfElse <$> (C.reserved "if" *> P.parens C.tokenParser parseJS)
- <*> parseJS
- <*> P.optionMaybe (C.reserved "else" >> parseJS)
-
-parseReturn :: P.Parsec String u JS
-parseReturn = JSReturn <$> (C.reserved "return" *> parseJS <* C.semi)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 17f8cce..d88f906 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -48,7 +48,10 @@ parseObject :: P.Parsec String ParseState Type
parseObject = braces $ Object <$> parseRow False
parseTypeVariable :: P.Parsec String ParseState Type
-parseTypeVariable = TypeVar <$> identifier
+parseTypeVariable = do
+ ident <- identifier
+ when (ident `elem` reservedTypeNames) $ P.unexpected $ ident
+ return $ TypeVar ident
parseTypeConstructor :: P.Parsec String ParseState Type
parseTypeConstructor = TypeConstructor <$> parseQualified properName
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 6ea2f4f..07fd6f4 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -209,8 +209,8 @@ parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.s
--
parseStatement :: P.Parsec String ParseState Statement
parseStatement = P.choice
- [ parseVariableIntroduction
- , parseAssignment
+ [ parseAssignment
+ , parseVariableIntroduction
, parseWhile
, parseFor
, parseIf
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 289fb85..3407b09 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -20,6 +20,7 @@ module Language.PureScript.Pretty.Types (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
+import Data.Generics (mkT, everywhere)
import Control.Arrow ((<+>))
import Control.PatternArrows
@@ -33,8 +34,8 @@ 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 (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
+ match ty@(TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
match (Skolem s _) = Just $ 's' : show s
match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty
@@ -68,23 +69,30 @@ typeApp = mkPattern match
match (TypeApp f x) = Just (f, x)
match _ = Nothing
-singleArgumentFunction :: Pattern () Type (Type, Type)
-singleArgumentFunction = mkPattern match
+appliedFunction :: Pattern () Type (Type, Type)
+appliedFunction = mkPattern match
where
- match (TypeApp (TypeApp t arg) ret) | t == tyFunction = Just (arg, ret)
+ match (PrettyPrintFunction arg ret) = Just (arg, ret)
match _ = Nothing
+insertPlaceholders :: Type -> Type
+insertPlaceholders = everywhere (mkT convert)
+ where
+ convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
+ convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
+ convert other = other
+
-- |
-- Generate a pretty-printed string representing a Type
--
prettyPrintType :: Type -> String
-prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
where
matchType :: Pattern () Type String
matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
operators :: OperatorTable () Type String
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
- , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
+ , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
]
]
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index b6c3852..d76928c 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -60,7 +60,7 @@ customOperatorTable fixities =
let
applyUserOp name t1 t2 = App (App (Var name) t1) t2
userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
- sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
+ sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
in
map (map (\(name, f, _, a) -> (name, f, a))) groups
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index e8d8b91..e1c790e 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -43,13 +43,14 @@ addDataType moduleName name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
forM_ dctors $ \(dctor, maybeTy) ->
- rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $
+ rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
addDataConstructor moduleName name args dctor maybeTy
addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()
addDataConstructor moduleName name args dctor maybeTy = do
env <- getEnv
dataConstructorIsNotDefined moduleName dctor
+ when (runModuleName moduleName == dctor) $ throwError "A data constructor may not have the same name as its enclosing module."
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = maybe retTy (flip function retTy) maybeTy
let polyType = mkForAll args dctorTy
@@ -89,6 +90,15 @@ addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries = do
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+checkTypeClassInstance :: ModuleName -> Type -> Check ()
+checkTypeClassInstance _ (TypeVar _) = return ()
+checkTypeClassInstance m (TypeConstructor ctor) = do
+ env <- getEnv
+ when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
+ return ()
+checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
+checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
+
-- |
-- Type check all declarations in a module
--
@@ -241,6 +251,8 @@ typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
env <- getEnv
dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
+ checkTypeClassInstance moduleName ty
+ forM_ deps $ checkTypeClassInstance moduleName . snd
addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
[TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
ds <- typeCheckAll moduleName rest
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5e06cf9..dbeb44b 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -143,9 +143,11 @@ infer (TypeApp t1 t2) = do
k1 =?= FunKind k2 k0
return k0
infer (ForAll ident ty _) = do
- k <- fresh
+ k1 <- fresh
Just moduleName <- checkCurrentModule <$> get
- bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
+ k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
+ k2 =?= Star
+ return Star
infer REmpty = do
k <- fresh
return $ Row k
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 1a954ca..48fc6ee 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -115,10 +115,20 @@ data Environment = Environment {
} deriving (Show)
-- |
--- An empty environment with no values and no types defined
+-- The basic types existing in the external javascript environment
--
-emptyEnvironment :: Environment
-emptyEnvironment = Environment M.empty M.empty M.empty M.empty []
+jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
+jsTypes = M.fromList [ ((ModuleName $ ProperName "Prim", ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))
+ , ((ModuleName $ ProperName "Prim", ProperName "Array"), (FunKind Star Star, ExternData))
+ , ((ModuleName $ ProperName "Prim", ProperName "String"), (Star, ExternData))
+ , ((ModuleName $ ProperName "Prim", ProperName "Number"), (Star, ExternData))
+ , ((ModuleName $ ProperName "Prim", ProperName "Boolean"), (Star, ExternData)) ]
+
+-- |
+-- The initial environment with no values and only the default javascript types defined
+--
+initEnvironment :: Environment
+initEnvironment = Environment M.empty jsTypes M.empty M.empty []
-- |
-- Temporarily bind a collection of names to values
@@ -271,7 +281,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
--
runCheck :: Check a -> Either String (a, Environment)
runCheck c = do
- (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0 Nothing) $ unCheck c
+ (a, s) <- flip runStateT (CheckState initEnvironment 0 0 Nothing) $ unCheck c
return (a, checkEnv s)
-- |
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c155eba..2cf7aec 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -354,9 +354,17 @@ replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
-- |
-- Replace named type variables with new unification variables
--
-replaceAllVarsWithUnknowns :: Type -> UnifyT Type Check Type
-replaceAllVarsWithUnknowns (ForAll ident ty _) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
-replaceAllVarsWithUnknowns ty = return ty
+instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)
+instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
+ ty' <- replaceVarWithUnknown ident ty
+ instantiatePolyTypeWithUnknowns val ty'
+instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
+ env <- getEnv
+ Just moduleName <- checkCurrentModule <$> get
+ dicts <- getTypeClassDictionaries
+ (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
+ return (foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)), ty')
+instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- |
-- Replace a single type variable with a new unification variable
@@ -460,10 +468,10 @@ infer' (Var var) = do
Just moduleName <- checkCurrentModule <$> get
ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
case ty of
- ConstrainedType constraints _ -> do
+ ConstrainedType constraints ty' -> do
env <- getEnv
dicts <- getTypeClassDictionaries
- return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty
+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
_ -> return $ TypedValue True (Var var) ty
infer' (Block ss) = do
ret <- fresh
@@ -534,7 +542,7 @@ inferBinder val (UnaryBinder ctor binder) = do
Just moduleName <- checkCurrentModule <$> get
case M.lookup (qualify moduleName ctor) (dataConstructors env) of
Just (ty, _) -> do
- fn <- replaceAllVarsWithUnknowns ty
+ (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
case fn of
TypeApp (TypeApp t obj) ret | t == tyFunction -> do
_ <- subsumes Nothing val ret
@@ -739,9 +747,9 @@ check' val t@(SaturatedTypeSynonym name args) = do
check' val u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
- ty' <- replaceAllVarsWithUnknowns ty
+ (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
ty' =?= u
- return $ TypedValue True val' ty'
+ return $ TypedValue True val'' ty'
check' v@(NumericLiteral _) t | t == tyNumber =
return $ TypedValue True v t
check' v@(StringLiteral _) t | t == tyString =
@@ -879,7 +887,8 @@ checkFunctionApplication' fn (ForAll ident ty _) arg = do
checkFunctionApplication' fn u@(TUnknown _) arg = do
arg' <- do
TypedValue _ v t <- infer arg
- TypedValue True v <$> replaceAllVarsWithUnknowns t
+ (v', t') <- instantiatePolyTypeWithUnknowns arg t
+ return $ TypedValue True v' t'
let ty = (\(TypedValue _ _ t) -> t) arg'
ret <- fresh
u =?= function ty ret
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index befe328..0bec97e 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -76,37 +76,45 @@ data Type
-- |
-- A non-empty row
--
- | RCons String Type Type deriving (Show, Eq, Data, Typeable)
+ | RCons String Type Type
+ -- |
+ -- A placeholder used in pretty printing
+ --
+ | PrettyPrintFunction Type Type
+ -- |
+ -- A placeholder used in pretty printing
+ --
+ | PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)
-- |
-- Type constructor for functions
--
tyFunction :: Type
-tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Function")
+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Function")
-- |
-- Type constructor for strings
--
tyString :: Type
-tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "String")
+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "String")
-- |
-- Type constructor for numbers
--
tyNumber :: Type
-tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Number")
+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Number")
-- |
-- Type constructor for booleans
--
tyBoolean :: Type
-tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Boolean")
+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Boolean")
-- |
-- Type constructor for arrays
--
tyArray :: Type
-tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prelude") (ProperName "Array")
+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Array")
-- |
-- Smart constructor for function types