packages feed

purescript 0.3.9 → 0.3.10

raw patch · 16 files changed

+414/−340 lines, 16 filesdep ~monad-unifynew-component:exe:docgen

Dependency ranges changed: monad-unify

Files

+ docgen/Main.hs view
@@ -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)
libraries/prelude/prelude.purs view
@@ -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 @@     (<<<) 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 @@     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 @@     (%) = numMod     negate = numNegate -  infixl 9 ==-  infixl 9 /=+  infixl 4 ==+  infixl 4 /=    class Eq a where     (==) :: a -> a -> Boolean@@ -205,10 +201,10 @@     (==) _ _ = 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 @@     zshr = numZshr     complement = numComplement -  infixl 4 !!+  infixl 8 !!    foreign import (!!) "function $bang$bang(xs) {\                       \  return function(n) {\@@ -316,8 +312,8 @@                       \  };\                       \}" :: forall a. [a] -> Number -> a -  infixr 11 ||-  infixr 11 &&+  infixr 2 ||+  infixr 3 &&    class BoolLike b where     (&&) :: b -> b -> b@@ -345,7 +341,7 @@     (||) = boolOr     not = boolNot -  infixr 6 +++  infixr 5 ++    foreign import (++) "function $plus$plus(s1) {\                       \  return function(s2) {\@@ -362,7 +358,7 @@   class Monoid m where     mempty :: m     (<>) :: m -> m -> m-  +   instance Monoid String where     mempty = ""     (<>) = (++)@@ -377,18 +373,18 @@   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 @@   (>=>) 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 @@     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 @@   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 @@   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 @@     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 @@                          \}" :: 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 @@                         \    };\                         \  };\                         \}" :: forall e. Eff e Boolean -> Eff e {} -> Eff e {}- +   foreign import forE "function forE(lo) {\ 	              \  return function(hi) {\ 	              \    return function(f) {\@@ -999,6 +998,10 @@                             \    };\                             \  };\                             \}" :: 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
purescript.cabal view
@@ -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 @@                      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@@ -83,6 +82,15 @@     main-is: Main.hs     buildable: True     hs-source-dirs: 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
src/Language/PureScript/Names.hs view
@@ -52,7 +52,7 @@ -- | -- 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
src/Language/PureScript/Parser/Common.hs view
@@ -27,62 +27,102 @@ import Language.PureScript.Names  -- |--- A list of reserved identifiers+-- A list of purescript 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" ]+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 -- reservedOpNames :: [String]@@ -95,12 +135,6 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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
src/Language/PureScript/Parser/Declarations.hs view
@@ -31,7 +31,6 @@ 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 @@  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 @@  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.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 =
− src/Language/PureScript/Parser/JS.hs 
@@ -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)
src/Language/PureScript/Parser/Types.hs view
@@ -48,7 +48,10 @@ 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
src/Language/PureScript/Parser/Values.hs view
@@ -209,8 +209,8 @@ -- parseStatement :: P.Parsec String ParseState Statement parseStatement = P.choice-                 [ parseVariableIntroduction-                 , parseAssignment+                 [ parseAssignment+                 , parseVariableIntroduction                  , parseWhile                  , parseFor                  , parseIf
src/Language/PureScript/Pretty/Types.hs view
@@ -20,6 +20,7 @@  import Data.Maybe (fromMaybe) import Data.List (intercalate)+import Data.Generics (mkT, everywhere)  import Control.Arrow ((<+>)) import Control.PatternArrows@@ -33,8 +34,8 @@   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 @@   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                     ]                   ]
src/Language/PureScript/Sugar/Operators.hs view
@@ -60,7 +60,7 @@   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
src/Language/PureScript/TypeChecker.hs view
@@ -43,13 +43,14 @@   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 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@(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
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -143,9 +143,11 @@   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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -115,12 +115,22 @@   } 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 -- bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a@@ -271,7 +281,7 @@ -- 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)  -- |
src/Language/PureScript/TypeChecker/Types.hs view
@@ -354,9 +354,17 @@ -- | -- 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 @@   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 @@   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 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 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
src/Language/PureScript/Types.hs view
@@ -76,37 +76,45 @@   -- |   -- 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