Update for 0.7

Author: paf31

Main.hs

@@ -12,20 +12,29 @@
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE DataKinds, OverloadedStrings, TemplateHaskell #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Main (
     main
 ) where
 
 import qualified Language.PureScript as P
+import qualified Language.PureScript.CodeGen.JS as J
+import qualified Language.PureScript.CoreFn as CF
+import qualified Language.PureScript.Bundle as B
 
 import Data.Version (showVersion)
 import Data.Monoid
 import Data.String
 import Data.Maybe (mapMaybe)
 import Data.List (intercalate)
 import Data.FileEmbed
+import Data.Time.Clock (UTCTime())
+import Data.Foldable (traverse_)
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BC8
@@ -40,6 +49,10 @@ import Control.Applicative
 import Control.Monad (when, forM_)
 import Control.Monad.Trans
 import Control.Monad.Reader
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Trans.Except
+import Control.Monad.Reader
+import Control.Monad.Writer
 
 import Network.HTTP.Types (status500)
 
@@ -56,30 +69,63 @@ import qualified Paths_trypurescript as Paths
 
 import System.Environment (getArgs)
 
-data Compiled = Compiled { js      :: String
-                         , externs :: String
-                         }
+newtype Compiled = Compiled { runCompiled :: String }
 
 newtype Response = Response { runResponse :: Either String Compiled }
 
-options :: P.Options P.Compile
-options = P.defaultCompileOptions 
-            { P.optionsAdditional = P.CompileOptions "PS" [] []
-            , P.optionsMain = Just "Main"
-            }
-
-compile :: [P.Module] -> String -> IO Response
-compile _ input | length input > 20000 = return $ Response $ Left "Please limit your input to 20000 characters"
-compile prelude input = do
+type FS = M.Map B.ModuleIdentifier String
+
+newtype Try a = Try { unTry :: ReaderT P.Options (WriterT P.MultipleErrors (WriterT FS (Either P.MultipleErrors))) a }
+  deriving (Functor, Applicative, Monad, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
+
+runTry :: Try a -> Either P.MultipleErrors (a, FS)
+runTry = runWriterT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTry
+
+writeTextFileTry :: B.ModuleIdentifier -> String -> Try ()
+writeTextFileTry mid txt = Try . lift . lift . tell $ M.singleton mid txt
+
+makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Try
+makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
+  where
+  getInputTimestamp :: P.ModuleName -> Try (Either P.RebuildPolicy (Maybe UTCTime))
+  getInputTimestamp _ = return (Left P.RebuildAlways)
+  
+  getOutputTimestamp :: P.ModuleName -> Try (Maybe UTCTime)
+  getOutputTimestamp mn = return (Just (error "getOutputTimestamp: read timestamp"))
+
+  readExterns :: P.ModuleName -> Try (FilePath, String)
+  readExterns _ = error "readExterns: not supported"
+  
+  codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Try ()
+  codegen m _ nextVar exts = do
+    let mn = P.runModuleName (CF.moduleName m)
+    foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of
+      (Just path, fs) | not (null fs) -> 
+        return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
+      _ -> 
+        return Nothing
+    pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
+    writeTextFileTry (B.ModuleIdentifier mn B.Regular) pjs
+    traverse_ (writeTextFileTry (B.ModuleIdentifier mn B.Foreign) . snd) (CF.moduleName m `M.lookup` foreigns)
+      
+  progress :: String -> Try ()
+  progress _ = return ()
+  
+compile :: [P.Module] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> String -> IO Response
+compile _ _ input | length input > 20000 = return $ Response $ Left "Please limit your input to 20000 characters"
+compile prelude foreigns input = do
   case either Left (Right . map snd) $ P.parseModulesFromFiles (const "<file>") [(undefined, input)] of
     Left parseError -> do
       return $ Response $ Left $ show parseError
     Right modules -> do
-      case flip runReaderT options $ P.compile (prelude ++ modules) ["Generated by trypurescript"] of
-        Left error ->
-          return $ Response $ Left error
-        Right (js, externs, _) ->
-          return $ Response $ Right $ Compiled js externs
+      let allModules = map (Left P.RebuildNever, ) prelude ++ map (Left P.RebuildAlways, ) modules
+      case runTry (P.make (makeActions foreigns) allModules) of
+        Left err ->
+          return $ Response $ Left (P.prettyPrintMultipleErrors False err)
+        Right (_, fs) ->
+          case B.bundle (M.toList fs) [B.ModuleIdentifier "Main" B.Regular] (Just "Main") "TryPS" of
+            Left err -> return $ Response $ Left (unlines (B.printErrorMessage err))
+            Right js -> return $ Response $ Right $ Compiled js
 
 str :: String -> String
 str = id
@@ -99,14 +145,25 @@ scripts = BC8.unpack $(embedFile "assets/scripts.js")
 defaultCode :: String
 defaultCode = BC8.unpack $(embedFile "examples/default.purs")
 
+preludePurs :: [String]
+preludePurs = 
+  [ BC8.unpack $(embedFile "prelude/Prelude.purs")
+  , BC8.unpack $(embedFile "prelude/Control/Monad/Eff.purs")
+  , BC8.unpack $(embedFile "prelude/Control/Monad/Eff/Console.purs")
+  ]
+
+preludeJs :: [String]
+preludeJs = 
+  [ BC8.unpack $(embedFile "prelude/Prelude.js")
+  , BC8.unpack $(embedFile "prelude/Control/Monad/Eff.js")
+  , BC8.unpack $(embedFile "prelude/Control/Monad/Eff/Console.js")
+  ]
+
 examples :: [(String, (String, String))]
 examples =
   [ ("adt",         ("Algebraic Data Types",  BC8.unpack $(embedFile "examples/adt.purs")))
   , ("ops",         ("Operators",             BC8.unpack $(embedFile "examples/operators.purs")))
-  , ("arrays",      ("Arrays",                BC8.unpack $(embedFile "examples/arrays.purs")))
   , ("rows",        ("Row Polymorphism",      BC8.unpack $(embedFile "examples/rows.purs")))
-  , ("ffi",         ("FFI",                   BC8.unpack $(embedFile "examples/ffi.purs")))
-  , ("mutable",     ("Mutable Variables",     BC8.unpack $(embedFile "examples/mutable.purs")))
   , ("recursion",   ("Recursion",             BC8.unpack $(embedFile "examples/recursion.purs")))
   , ("do",          ("Do Notation",           BC8.unpack $(embedFile "examples/do.purs")))
   , ("tco",         ("Tail-Call Elimination", BC8.unpack $(embedFile "examples/tco.purs")))
@@ -128,32 +185,28 @@ page input = html $ renderHtml $ do
       H.script ! A.type_ "text/javascript" ! A.src "//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/mode-haskell.js" $ mempty
       H.script ! A.type_ "text/javascript" ! A.src "//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/theme-dawn.js" $ mempty
     H.body $ do
-        H.a ! A.href "https://github.com/purescript" $
-            H.img ! A.style "position: absolute; top: 0; right: 0; border: 0;"
-                  ! A.src "https://github-camo.global.ssl.fastly.net/365986a132ccd6a44c23a9169022c0b5c890c387/68747470733a2f2f73332e616d617a6f6e6177732e636f6d2f6769746875622f726962626f6e732f666f726b6d655f72696768745f7265645f6161303030302e706e67"
-                  ! A.alt "Fork me on GitHub"
-                  ! customAttribute "data-canonical-src" "https://s3.amazonaws.com/github/ribbons/forkme_right_red_aa0000.png"
-        H.div ! A.class_ "wrapper" $ do
-           H.div ! A.class_ "header" $ do
-               H.h1 $ H.toHtml $ str "Try PureScript!"
-           H.div ! A.class_ "body" $ do
-               H.p $ H.toHtml $ str "Type PureScript code below and press 'Compile', or select one of the examples below:"
-        
-               H.h2 $ H.toHtml $ str "Examples"
-               H.ul $ do
-                 forM_ examples $ \(name, (title, _)) ->
-                   H.li $ H.a ! A.href (fromString $ "/example/" ++ name) $ H.toHtml title
-        
-               H.h2 $ H.toHtml $ str "PureScript Code"
-               H.div ! A.id "code" $ mempty
-               H.textarea ! A.name "code" ! A.id "textarea" ! A.style "display: none;" $ H.toHtml $ str input
-               H.p $ H.button ! A.id "compile" $ H.toHtml $ str "Compile and Run"
-               H.script ! A.type_ "text/javascript" $ preEscapedToHtml scripts
-               H.div ! A.id "results" $ mempty
+      H.div ! A.class_ "wrapper" $ do
+         H.div ! A.class_ "header" $ do
+             H.h1 $ H.toHtml $ str "Try PureScript!"
+         H.div ! A.class_ "body" $ do
+             H.p $ H.toHtml $ str "Type PureScript code below and press 'Compile', or select one of the examples below:"
+      
+             H.h2 $ H.toHtml $ str "Examples"
+             H.ul $ do
+               forM_ examples $ \(name, (title, _)) ->
+                 H.li $ H.a ! A.href (fromString $ "/example/" ++ name) $ H.toHtml title
+      
+             H.h2 $ H.toHtml $ str "PureScript Code"
+             H.div ! A.id "code" $ mempty
+             H.textarea ! A.name "code" ! A.id "textarea" ! A.style "display: none;" $ H.toHtml $ str input
+             H.p $ H.button ! A.id "compile" $ H.toHtml $ str "Compile and Run"
+             H.script ! A.type_ "text/javascript" $ preEscapedToHtml scripts
+             H.div ! A.id "results" $ mempty
 
 server :: Int -> IO ()
 server port = do
-  let preludeModules = either (error . show) (map snd) $ P.parseModulesFromFiles (const "<prelude>") [(undefined, P.prelude)]
+  let preludeModules = either (error . show) (map snd) $ P.parseModulesFromFiles (const "<prelude>") (map (undefined, ) preludePurs)
+  Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles (map (error "foreign filename read", ) preludeJs)
   scotty port $ do
     get "/" $ do
       page defaultCode
@@ -165,12 +218,12 @@ server port = do
           page code
     post "/compile/text" $ do
       code <- BLC8.unpack <$> body
-      response <- lift $ compile preludeModules code
+      response <- lift $ compile preludeModules foreigns code
       case runResponse response of
         Left err -> do
           Scotty.json $ A.object [ "error" .= err ]
         Right comp -> 
-          Scotty.json $ A.object [ "js" .= js comp ]
+          Scotty.json $ A.object [ "js" .= runCompiled comp ]
 
 main :: IO ()
 main = do

assets/style.css

@@ -1,13 +1,28 @@
 /* Page layout */
 
+body
+{
+  font-family: 'Roboto', sans-serif;
+  line-height: 150%;
+  color: #404040;
+  margin: 0;
+  color: rgb(29, 34, 45);
+  overflow-y: scroll;
+}
+
 .wrapper {
-  max-width: 750px;
   margin: 0 auto;
-  padding: 20px;
 }
 
 .header {
   border-bottom: 1px solid #ddd;
+  background-color: rgb(29, 34, 45);
+  padding: 25px 40px;
+  color: white;
+}
+
+.body {
+  padding: 40px;
 }
 
 .footer {
@@ -18,26 +33,23 @@
 
 /* Typography */
 
-body
-{
-  font: 18px Roboto, sans-serif;
-  line-height: 150%;
-  color: #404040;
-  margin: 0;
-}
-
 h1, h2, h3 {
   line-height: 110%;
 }
 
 h1 {
-  margin: 40px 0 20px 0;
+  font-size: 2em;
+  font-weight: 300;
 }
 
 h2, h3 {
   margin: 40px 0 10px 0;
 }
 
+a, a:visited, a:active, a:hover {
+  color: #c4953a;
+}
+
 .info {
   margin-top: -6px;
   font-size: 12px;
@@ -69,26 +81,29 @@ pre code {
   padding: 0;
 }
 
-a {
-  color: #800000;
-}
-
 button {
-  background: #800000;
-  color: #ffffff;
-  padding: 10px 15px;
+  background: white;
+  color: #c4953a;
   font-size: 12px;
+  font-weight: bold;
+  text-transform: uppercase;
   border: 0;
-  box-shadow: 2px 2px 4px #BBAAAA;
   cursor: pointer;
+  border-top: 1px solid #c4953a;
+  padding: 8px 0px 6px 22px;
+  text-align: right;
 }
 
 button:hover {
-  background: #9B4242;
+  opacity: 0.7;
+}
+
+button:focus {
+  outline: 0;
 }
 
 iframe {
   width: 100%;
   border: 1px solid #f0f0f0;
   box-shadow: 0 0 10px #F6F6F6;
-}
+}

examples/adt.purs

@@ -1,14 +1,15 @@
 module Main where
-  
-import Debug.Trace
+    
+import Prelude
+import Control.Monad.Eff.Console (log)
 
-data Person = Person String Number 
-            
+data Person = Person String Int 
+                        
 showPerson :: Person -> String
 showPerson (Person name age) =
   name ++ ", aged " ++ show age
-    
+        
 person :: Person
 person = Person "John Smith" 30
 
-main = trace (showPerson person)
+main = log (showPerson person)

examples/arrays.purs

@@ -1,5 +1,6 @@
 module Main where
 
-import Debug.Trace
+import Prelude
+import Control.Monad.Eff.Console (log)
 
-main = trace "Hello, World!"
+main = log "Hello, World!"