packages feed

purescript 0.3.4 → 0.3.5

raw patch · 15 files changed

+114/−137 lines, 15 filesdep +pattern-arrows

Dependencies added: pattern-arrows

Files

libraries/prelude/prelude.purs view
@@ -495,6 +495,15 @@                            \  };\                            \}" :: forall s r. IORef s -> Eff (ref :: Ref | r) s ++  foreign import modifyIORef "function modifyIORef(ref) {\+                             \  return function(f) {\+                             \    return function() {\+                             \      ref.value = f(ref.value);\+                             \    };\+                             \  };\+                             \}" :: forall s r. IORef s -> (s -> s) -> Eff (ref :: Ref | r) {}+   foreign import writeIORef "function writeIORef(ref) {\                             \  return function(val) {\                             \    return function() {\@@ -540,14 +549,22 @@                            \  };\                            \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a -  foreign import modifySTRef "function modifySTRef(f) {\-                             \  return function(ref) {\+  foreign import modifySTRef "function modifySTRef(ref) {\+                             \  return function(f) {\                              \    return function() {\                              \      ref.value = f(ref.value);\                              \    };\                              \  };\-                             \}" :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}+                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) {} +  foreign import writeSTRef "function writeSTRef(ref) {\+                            \  return function(a) {\+                            \    return function() {\+                            \      ref.value = a;\+                            \    };\+                            \  };\+                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) {}+     foreign import runST "function runST(f) {\                        \  return f;\                        \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.3.4+version: 0.3.5 cabal-version: >=1.8 build-type: Simple license: MIT@@ -17,7 +17,7 @@ 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+                   transformers -any, utf8-string -any, pattern-arrows -any     exposed-modules: Data.Generics.Extras                      Language.PureScript                      Language.PureScript.Options
src/Language/PureScript/CodeGen/JS.hs view
@@ -41,13 +41,13 @@ import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.Types import Language.PureScript.CodeGen.Optimize+import Language.PureScript.TypeChecker.Monad (canonicalizeType)  -- | -- Generate code in the simplified Javascript intermediate representation for all declarations in a module -- moduleToJs :: Options -> Module -> Environment -> [JS] moduleToJs opts (Module pname@(ProperName name) decls) env =-  mapMaybe filterRawDecls decls ++   [ JSVariableIntroduction (Ident name) Nothing   , JSApp (JSFunction Nothing [Ident name]                       (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))@@ -55,8 +55,6 @@                          (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]   ]   where-  filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js-  filterRawDecls _ = Nothing   typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ   typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT   typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT@@ -87,7 +85,7 @@     in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ] declToJs opts mp (DataBindingGroupDeclaration ds) e =   Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds-declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ | importTy /= ForeignImport =+declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =   Just [ js        , setProperty (identToJs ident) (JSVar ident) mp ] declToJs _ _ _ _ = Nothing@@ -201,7 +199,7 @@   then     return done   else-    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]+    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeType m e ctor)))) (JSBlock done) Nothing] binderToJs m e varName done (UnaryBinder ctor b) = do   value <- fresh   js <- binderToJs m e value done b@@ -210,7 +208,7 @@   then     return [success]   else-    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))+    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeType m e ctor))))                      success                      Nothing] binderToJs m e varName done (ObjectBinder bs) = go done bs
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -129,7 +129,7 @@   -- |   -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)   ---  | JSRaw String deriving (Show, Data, Typeable)+  | JSRaw String deriving (Show, Eq, Data, Typeable)  -- | -- Data type for expressions which can appear on the left hand side of an assignment@@ -142,4 +142,4 @@   -- |   -- Assign an object property   ---  | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)+  | JSAssignProperty String JSAssignment deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/CodeGen/Optimize.hs view
@@ -27,6 +27,8 @@ -- --  * Inlining variables --+--  * Inline Prelude.($)+-- -----------------------------------------------------------------------------  module Language.PureScript.CodeGen.Optimize (@@ -49,15 +51,25 @@ -- Apply a series of optimizer passes to simplified Javascript code -- optimize :: Options -> JS -> JS-optimize opts =-  collapseNestedBlocks-  . tco opts-  . magicDo opts-  . removeUnusedVariables-  . unThunk-  . etaConvert-  . inlineVariables+optimize opts = untilFixedPoint $ applyAll+  [ collapseNestedBlocks+  , tco opts+  , magicDo opts+  , removeUnusedVariables+  , unThunk+  , etaConvert+  , inlineVariables+  , inlineDollar ] +applyAll :: [a -> a] -> a -> a+applyAll = foldl1 (.)++untilFixedPoint :: (Eq a) => (a -> a) -> a -> a+untilFixedPoint f a = go a+  where+  go a' = let a'' = f a' in+          if a'' == a' then a'' else go a''+ replaceIdent :: (Data d) => Ident -> JS -> d -> d replaceIdent var1 js = everywhere (mkT replace)   where@@ -279,3 +291,12 @@   go :: JS -> [JS]   go (JSBlock sts) = sts   go s = [s]++inlineDollar :: JS -> JS+inlineDollar = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSApp (JSApp dollar [f]) [x]) | isDollar dollar = JSApp f [x]+  convert other = other+  isDollar (JSAccessor name (JSVar (Ident "Prelude"))) | name == identToJs (Op "$") = True+  isDollar _ = False
src/Language/PureScript/Declarations.hs view
@@ -53,6 +53,10 @@   --   = ForeignImport   -- |+  -- A foreign import which contains inline Javascript as a string literal+  --+  | InlineJavascript+  -- |   -- A type class dictionary import, generated during desugaring of type class declarations   --   | TypeClassDictionaryImport
src/Language/PureScript/Parser/Common.hs view
@@ -78,7 +78,9 @@                 , "let"                 , "class"                 , "instance"-                , "where" ]+                , "where"+                , "null"+                , "undefined" ]  -- | -- A list of built-in operator names@@ -265,6 +267,19 @@ -- parseIdent :: P.Parsec String ParseState Ident parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)+++-- |+-- 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+  where+  isReserved (Ident ident) = ident `elem` reservedNames+  isReserved (Op op) = op `elem` reservedOpNames  -- | -- Parse a token inside square brackets
src/Language/PureScript/Parser/Declarations.hs view
@@ -19,7 +19,8 @@     parseModules ) where -import Data.Maybe (fromMaybe)+import Data.Maybe (isJust, fromMaybe)+import Control.Monad (when) import Control.Applicative import qualified Text.Parsec as P @@ -45,7 +46,7 @@  parseTypeDeclaration :: P.Parsec String ParseState Declaration parseTypeDeclaration =-  TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))+  TypeDeclaration <$> P.try (parseNonReservedIdent <* lexeme (indented *> P.string "::"))                   <*> parsePolyType  parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration@@ -56,7 +57,7 @@  parseValueDeclaration :: P.Parsec String ParseState Declaration parseValueDeclaration =-  ValueDeclaration <$> parseIdent+  ValueDeclaration <$> parseNonReservedIdent                    <*> P.many parseTopLevelBinder                    <*> P.optionMaybe parseGuard                    <*> ((lexeme (indented *> P.char '=')) *> parseValue)@@ -68,10 +69,10 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>    (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)                              <*> (lexeme (indented *> P.string "::") *> parseKind)-   <|> ExternDeclaration ForeignImport <$> parseIdent-                                       <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)-                                       <*> (lexeme (indented *> P.string "::") *> parsePolyType))-+   <|> do ident <- parseNonReservedIdent+          js <- P.optionMaybe (parseJSLiteral <$> 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
src/Language/PureScript/Parser/Types.hs view
@@ -24,7 +24,7 @@ import Control.Applicative import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P-import Control.Monad (unless)+import Control.Monad (when, unless)  parseNumber :: P.Parsec String ParseState Type parseNumber = const Number <$> reserved "Number"@@ -42,7 +42,7 @@ parseArrayOf = squares $ TypeApp Array <$> parseType  parseObject :: P.Parsec String ParseState Type-parseObject = braces $ Object <$> parseRow+parseObject = braces $ Object <$> parseRow False  parseFunction :: P.Parsec String ParseState Type parseFunction = do@@ -69,11 +69,10 @@             , parseArray             , parseArrayOf             , parseObject-            , parseFunction             , parseTypeVariable             , parseTypeConstructor             , parseForAll-            , parens parseRow+            , parens (parseRow True)             , parens parseType ])  parseConstrainedType :: P.Parsec String ParseState Type@@ -91,11 +90,10 @@   return $ maybe ty (flip ConstrainedType ty) constraints  parseAnyType :: P.Parsec String ParseState Type-parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"+parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) <|> parseFunction P.<?> "type"   where-  postfixTable :: [Type -> P.Parsec String ParseState Type]-  postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]-  operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]+  operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]+              , [ P.Infix (P.try (lexeme (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]  -- | -- Parse a monotype@@ -121,9 +119,6 @@ parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) -parseRow :: P.Parsec String ParseState Type-parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"-  where-  fromList :: [(String, Type)] -> Type -> Type-  fromList [] r = r-  fromList ((name, t):ts) r = RCons name t (fromList ts r)+parseRow :: Bool -> P.Parsec String ParseState Type+parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"+  where many = if nonEmpty then commaSep1 else commaSep
src/Language/PureScript/Pretty/Common.hs view
@@ -43,95 +43,7 @@ identCharToString c = '$' : show (ord c)  -- |--- A first-order pattern match------ A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.----newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)--instance Functor (Pattern u a) where-  fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p---- |--- Run a pattern with an input and initial user state------ Returns Nothing if the pattern fails to match----pattern :: Pattern u a b -> u -> a -> Maybe b-pattern p u = flip evalStateT u . A.runKleisli (runPattern p)---- |--- Construct a pattern from a function----mkPattern :: (a -> Maybe b) -> Pattern u a b-mkPattern f = Pattern $ A.Kleisli (lift . f)---- |--- Construct a pattern from a stateful function----mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b-mkPattern' = Pattern . A.Kleisli---- | -- Wrap a string in parentheses -- parens :: String -> String parens s = ('(':s) ++ ")"---- |--- Construct a pattern which recursively matches on the left-hand-side----chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r-chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)---- |--- Construct a pattern which recursively matches on the right-hand side----chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r-chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)---- |--- Construct a pattern which recursively matches on one-side of a tuple----wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r-wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)---- |--- Construct a pattern which matches a part of a tuple----split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r-split s f = s >>> A.arr (uncurry f)---- |--- A table of operators----data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }---- |--- An operator:------  [@AssocL@] A left-associative operator------  [@AssocR@] A right-associative operator------  [@Wrap@] A prefix-like or postfix-like operator------  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand----data Operator u a r where-  AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r-  AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r-  Wrap   :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r-  Split  :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r---- |--- Build a pretty printer from an operator table and an indecomposable pattern----buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r-buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->-  case op of-    AssocL pat g -> chainl pat g p'-    AssocR pat g -> chainr pat g p'-    Wrap pat g -> wrap pat g p'-    Split pat g -> split pat g-  ) <+> p') p $ runOperatorTable table
src/Language/PureScript/Pretty/JS.hs view
@@ -26,6 +26,7 @@ import Data.Maybe (fromMaybe) import qualified Control.Arrow as A import Control.Arrow ((<+>))+import Control.PatternArrows import Control.Applicative import Control.Monad.State
src/Language/PureScript/Pretty/Kinds.hs view
@@ -19,10 +19,12 @@  import Data.Maybe (fromMaybe) +import Control.Arrow (ArrowPlus(..))+import Control.PatternArrows+ import Language.PureScript.Kinds import Language.PureScript.Pretty.Common import Language.PureScript.Unknown-import Control.Arrow (ArrowPlus(..))  typeLiterals :: Pattern () Kind String typeLiterals = mkPattern match
src/Language/PureScript/Pretty/Types.hs view
@@ -20,7 +20,9 @@  import Data.Maybe (fromMaybe) import Data.List (intercalate)+ import Control.Arrow ((<+>))+import Control.PatternArrows  import Language.PureScript.Types import Language.PureScript.Pretty.Common
src/Language/PureScript/Pretty/Values.hs view
@@ -21,6 +21,7 @@ import Data.Maybe (fromMaybe) import Data.List (intercalate) import Control.Arrow ((<+>))+import Control.PatternArrows  import Language.PureScript.Types import Language.PureScript.Values
tests/Main.hs view
@@ -19,12 +19,14 @@ import qualified Language.PureScript as P  import Data.List (isSuffixOf)+import Data.Traversable (traverse) import Control.Applicative import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import System.Exit import System.Process import System.FilePath (pathSeparator)-import System.Directory (getCurrentDirectory, getDirectoryContents)+import System.Directory (getCurrentDirectory, getDirectoryContents, findExecutable) import System.Environment (getArgs) import Text.Parsec (ParseError) import qualified Paths_purescript as Paths@@ -68,11 +70,17 @@     args <- getArgs     if "--run-js" `elem` args     then do-      (exitCode, out, err) <- readProcessWithExitCode "nodejs" [] js-      case exitCode of-        ExitSuccess -> putStrLn out >> return Nothing-        ExitFailure code -> return $ Just err+      process <- findNodeProcess+      result <- traverse (\node -> readProcessWithExitCode node [] js) process+      case result of+        Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing+        Just (ExitFailure _, _, err) -> return $ Just err+        Nothing -> return $ Just "Couldn't find node.js executable"     else return Nothing++findNodeProcess :: IO (Maybe String)+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names+    where names = ["nodejs", "node"]  assertDoesNotCompile :: FilePath -> IO () assertDoesNotCompile inputFile = do