Skip to content

Commit 364b959

Browse files
paf31paf31
committed
Update for 0.7
1 parent b516271 commit 364b959

20 files changed

+1450
-174
lines changed

‎Main.hs

Lines changed: 99 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -12,20 +12,29 @@
1212
--
1313
-----------------------------------------------------------------------------
1414

15-
{-# LANGUAGE DataKinds, OverloadedStrings, TemplateHaskell #-}
15+
{-# LANGUAGE DataKinds #-}
16+
{-# LANGUAGE OverloadedStrings #-}
17+
{-# LANGUAGE TemplateHaskell #-}
18+
{-# LANGUAGE TupleSections #-}
19+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1620

1721
module Main (
1822
main
1923
) where
2024

2125
import qualified Language.PureScript as P
26+
import qualified Language.PureScript.CodeGen.JS as J
27+
import qualified Language.PureScript.CoreFn as CF
28+
import qualified Language.PureScript.Bundle as B
2229

2330
import Data.Version (showVersion)
2431
import Data.Monoid
2532
import Data.String
2633
import Data.Maybe (mapMaybe)
2734
import Data.List (intercalate)
2835
import Data.FileEmbed
36+
import Data.Time.Clock (UTCTime())
37+
import Data.Foldable (traverse_)
2938

3039
import qualified Data.ByteString as B
3140
import qualified Data.ByteString.Char8 as BC8
@@ -40,6 +49,10 @@ import Control.Applicative
4049
import Control.Monad (when, forM_)
4150
import Control.Monad.Trans
4251
import Control.Monad.Reader
52+
import Control.Monad.Error.Class (MonadError(..))
53+
import Control.Monad.Trans.Except
54+
import Control.Monad.Reader
55+
import Control.Monad.Writer
4356

4457
import Network.HTTP.Types (status500)
4558

@@ -56,30 +69,63 @@ import qualified Paths_trypurescript as Paths
5669

5770
import System.Environment (getArgs)
5871

59-
data Compiled = Compiled { js :: String
60-
, externs :: String
61-
}
72+
newtype Compiled = Compiled { runCompiled :: String }
6273

6374
newtype Response = Response { runResponse :: Either String Compiled }
6475

65-
options :: P.Options P.Compile
66-
options = P.defaultCompileOptions
67-
{ P.optionsAdditional = P.CompileOptions "PS" [] []
68-
, P.optionsMain = Just "Main"
69-
}
70-
71-
compile :: [P.Module] -> String -> IO Response
72-
compile _ input | length input > 20000 = return $ Response $ Left "Please limit your input to 20000 characters"
73-
compile prelude input = do
76+
type FS = M.Map B.ModuleIdentifier String
77+
78+
newtype Try a = Try { unTry :: ReaderT P.Options (WriterT P.MultipleErrors (WriterT FS (Either P.MultipleErrors))) a }
79+
deriving (Functor, Applicative, Monad, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
80+
81+
runTry :: Try a -> Either P.MultipleErrors (a, FS)
82+
runTry = runWriterT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTry
83+
84+
writeTextFileTry :: B.ModuleIdentifier -> String -> Try ()
85+
writeTextFileTry mid txt = Try . lift . lift . tell $ M.singleton mid txt
86+
87+
makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Try
88+
makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
89+
where
90+
getInputTimestamp :: P.ModuleName -> Try (Either P.RebuildPolicy (Maybe UTCTime))
91+
getInputTimestamp _ = return (Left P.RebuildAlways)
92+
93+
getOutputTimestamp :: P.ModuleName -> Try (Maybe UTCTime)
94+
getOutputTimestamp mn = return (Just (error "getOutputTimestamp: read timestamp"))
95+
96+
readExterns :: P.ModuleName -> Try (FilePath, String)
97+
readExterns _ = error "readExterns: not supported"
98+
99+
codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Try ()
100+
codegen m _ nextVar exts = do
101+
let mn = P.runModuleName (CF.moduleName m)
102+
foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of
103+
(Just path, fs) | not (null fs) ->
104+
return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
105+
_ ->
106+
return Nothing
107+
pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
108+
writeTextFileTry (B.ModuleIdentifier mn B.Regular) pjs
109+
traverse_ (writeTextFileTry (B.ModuleIdentifier mn B.Foreign) . snd) (CF.moduleName m `M.lookup` foreigns)
110+
111+
progress :: String -> Try ()
112+
progress _ = return ()
113+
114+
compile :: [P.Module] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> String -> IO Response
115+
compile _ _ input | length input > 20000 = return $ Response $ Left "Please limit your input to 20000 characters"
116+
compile prelude foreigns input = do
74117
case either Left (Right . map snd) $ P.parseModulesFromFiles (const "<file>") [(undefined, input)] of
75118
Left parseError -> do
76119
return $ Response $ Left $ show parseError
77120
Right modules -> do
78-
case flip runReaderT options $ P.compile (prelude ++ modules) ["Generated by trypurescript"] of
79-
Left error ->
80-
return $ Response $ Left error
81-
Right (js, externs, _) ->
82-
return $ Response $ Right $ Compiled js externs
121+
let allModules = map (Left P.RebuildNever, ) prelude ++ map (Left P.RebuildAlways, ) modules
122+
case runTry (P.make (makeActions foreigns) allModules) of
123+
Left err ->
124+
return $ Response $ Left (P.prettyPrintMultipleErrors False err)
125+
Right (_, fs) ->
126+
case B.bundle (M.toList fs) [B.ModuleIdentifier "Main" B.Regular] (Just "Main") "TryPS" of
127+
Left err -> return $ Response $ Left (unlines (B.printErrorMessage err))
128+
Right js -> return $ Response $ Right $ Compiled js
83129

84130
str :: String -> String
85131
str = id
@@ -99,14 +145,25 @@ scripts = BC8.unpack $(embedFile "assets/scripts.js")
99145
defaultCode :: String
100146
defaultCode = BC8.unpack $(embedFile "examples/default.purs")
101147

148+
preludePurs :: [String]
149+
preludePurs =
150+
[ BC8.unpack $(embedFile "prelude/Prelude.purs")
151+
, BC8.unpack $(embedFile "prelude/Control/Monad/Eff.purs")
152+
, BC8.unpack $(embedFile "prelude/Control/Monad/Eff/Console.purs")
153+
]
154+
155+
preludeJs :: [String]
156+
preludeJs =
157+
[ BC8.unpack $(embedFile "prelude/Prelude.js")
158+
, BC8.unpack $(embedFile "prelude/Control/Monad/Eff.js")
159+
, BC8.unpack $(embedFile "prelude/Control/Monad/Eff/Console.js")
160+
]
161+
102162
examples :: [(String, (String, String))]
103163
examples =
104164
[ ("adt", ("Algebraic Data Types", BC8.unpack $(embedFile "examples/adt.purs")))
105165
, ("ops", ("Operators", BC8.unpack $(embedFile "examples/operators.purs")))
106-
, ("arrays", ("Arrays", BC8.unpack $(embedFile "examples/arrays.purs")))
107166
, ("rows", ("Row Polymorphism", BC8.unpack $(embedFile "examples/rows.purs")))
108-
, ("ffi", ("FFI", BC8.unpack $(embedFile "examples/ffi.purs")))
109-
, ("mutable", ("Mutable Variables", BC8.unpack $(embedFile "examples/mutable.purs")))
110167
, ("recursion", ("Recursion", BC8.unpack $(embedFile "examples/recursion.purs")))
111168
, ("do", ("Do Notation", BC8.unpack $(embedFile "examples/do.purs")))
112169
, ("tco", ("Tail-Call Elimination", BC8.unpack $(embedFile "examples/tco.purs")))
@@ -128,32 +185,28 @@ page input = html $ renderHtml $ do
128185
H.script ! A.type_ "text/javascript" ! A.src "//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/mode-haskell.js" $ mempty
129186
H.script ! A.type_ "text/javascript" ! A.src "//cdnjs.cloudflare.com/ajax/libs/ace/1.1.01/theme-dawn.js" $ mempty
130187
H.body $ do
131-
H.a ! A.href "https://github.com/purescript" $
132-
H.img ! A.style "position: absolute; top: 0; right: 0; border: 0;"
133-
! A.src "https://github-camo.global.ssl.fastly.net/365986a132ccd6a44c23a9169022c0b5c890c387/68747470733a2f2f73332e616d617a6f6e6177732e636f6d2f6769746875622f726962626f6e732f666f726b6d655f72696768745f7265645f6161303030302e706e67"
134-
! A.alt "Fork me on GitHub"
135-
! customAttribute "data-canonical-src" "https://s3.amazonaws.com/github/ribbons/forkme_right_red_aa0000.png"
136-
H.div ! A.class_ "wrapper" $ do
137-
H.div ! A.class_ "header" $ do
138-
H.h1 $ H.toHtml $ str "Try PureScript!"
139-
H.div ! A.class_ "body" $ do
140-
H.p $ H.toHtml $ str "Type PureScript code below and press 'Compile', or select one of the examples below:"
141-
142-
H.h2 $ H.toHtml $ str "Examples"
143-
H.ul $ do
144-
forM_ examples $ \(name, (title, _)) ->
145-
H.li $ H.a ! A.href (fromString $ "/example/" ++ name) $ H.toHtml title
146-
147-
H.h2 $ H.toHtml $ str "PureScript Code"
148-
H.div ! A.id "code" $ mempty
149-
H.textarea ! A.name "code" ! A.id "textarea" ! A.style "display: none;" $ H.toHtml $ str input
150-
H.p $ H.button ! A.id "compile" $ H.toHtml $ str "Compile and Run"
151-
H.script ! A.type_ "text/javascript" $ preEscapedToHtml scripts
152-
H.div ! A.id "results" $ mempty
188+
H.div ! A.class_ "wrapper" $ do
189+
H.div ! A.class_ "header" $ do
190+
H.h1 $ H.toHtml $ str "Try PureScript!"
191+
H.div ! A.class_ "body" $ do
192+
H.p $ H.toHtml $ str "Type PureScript code below and press 'Compile', or select one of the examples below:"
193+
194+
H.h2 $ H.toHtml $ str "Examples"
195+
H.ul $ do
196+
forM_ examples $ \(name, (title, _)) ->
197+
H.li $ H.a ! A.href (fromString $ "/example/" ++ name) $ H.toHtml title
198+
199+
H.h2 $ H.toHtml $ str "PureScript Code"
200+
H.div ! A.id "code" $ mempty
201+
H.textarea ! A.name "code" ! A.id "textarea" ! A.style "display: none;" $ H.toHtml $ str input
202+
H.p $ H.button ! A.id "compile" $ H.toHtml $ str "Compile and Run"
203+
H.script ! A.type_ "text/javascript" $ preEscapedToHtml scripts
204+
H.div ! A.id "results" $ mempty
153205

154206
server :: Int -> IO ()
155207
server port = do
156-
let preludeModules = either (error . show) (map snd) $ P.parseModulesFromFiles (const "<prelude>") [(undefined, P.prelude)]
208+
let preludeModules = either (error . show) (map snd) $ P.parseModulesFromFiles (const "<prelude>") (map (undefined, ) preludePurs)
209+
Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles (map (error "foreign filename read", ) preludeJs)
157210
scotty port $ do
158211
get "/" $ do
159212
page defaultCode
@@ -165,12 +218,12 @@ server port = do
165218
page code
166219
post "/compile/text" $ do
167220
code <- BLC8.unpack <$> body
168-
response <- lift $ compile preludeModules code
221+
response <- lift $ compile preludeModules foreigns code
169222
case runResponse response of
170223
Left err -> do
171224
Scotty.json $ A.object [ "error" .= err ]
172225
Right comp ->
173-
Scotty.json $ A.object [ "js" .= js comp ]
226+
Scotty.json $ A.object [ "js" .= runCompiled comp ]
174227

175228
main :: IO ()
176229
main = do

‎assets/style.css

Lines changed: 36 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,28 @@
11
/* Page layout */
22

3+
body
4+
{
5+
font-family: 'Roboto', sans-serif;
6+
line-height: 150%;
7+
color: #404040;
8+
margin: 0;
9+
color: rgb(29, 34, 45);
10+
overflow-y: scroll;
11+
}
12+
313
.wrapper {
4-
max-width: 750px;
514
margin: 0 auto;
6-
padding: 20px;
715
}
816

917
.header {
1018
border-bottom: 1px solid #ddd;
19+
background-color: rgb(29, 34, 45);
20+
padding: 25px 40px;
21+
color: white;
22+
}
23+
24+
.body {
25+
padding: 40px;
1126
}
1227

1328
.footer {
@@ -18,26 +33,23 @@
1833

1934
/* Typography */
2035

21-
body
22-
{
23-
font: 18px Roboto, sans-serif;
24-
line-height: 150%;
25-
color: #404040;
26-
margin: 0;
27-
}
28-
2936
h1, h2, h3 {
3037
line-height: 110%;
3138
}
3239

3340
h1 {
34-
margin: 40px 0 20px 0;
41+
font-size: 2em;
42+
font-weight: 300;
3543
}
3644

3745
h2, h3 {
3846
margin: 40px 0 10px 0;
3947
}
4048

49+
a, a:visited, a:active, a:hover {
50+
color: #c4953a;
51+
}
52+
4153
.info {
4254
margin-top: -6px;
4355
font-size: 12px;
@@ -69,26 +81,29 @@ pre code {
6981
padding: 0;
7082
}
7183

72-
a {
73-
color: #800000;
74-
}
75-
7684
button {
77-
background: #800000;
78-
color: #ffffff;
79-
padding: 10px 15px;
85+
background: white;
86+
color: #c4953a;
8087
font-size: 12px;
88+
font-weight: bold;
89+
text-transform: uppercase;
8190
border: 0;
82-
box-shadow: 2px 2px 4px #BBAAAA;
8391
cursor: pointer;
92+
border-top: 1px solid #c4953a;
93+
padding: 8px 0px 6px 22px;
94+
text-align: right;
8495
}
8596

8697
button:hover {
87-
background: #9B4242;
98+
opacity: 0.7;
99+
}
100+
101+
button:focus {
102+
outline: 0;
88103
}
89104

90105
iframe {
91106
width: 100%;
92107
border: 1px solid #f0f0f0;
93108
box-shadow: 0 0 10px #F6F6F6;
94-
}
109+
}

‎examples/adt.purs

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,15 @@
11
module Main where
2-
3-
import Debug.Trace
2+
3+
import Prelude
4+
import Control.Monad.Eff.Console (log)
45

5-
data Person = Person String Number
6-
6+
data Person = Person String Int
7+
78
showPerson :: Person -> String
89
showPerson (Person name age) =
910
name ++ ", aged " ++ show age
10-
11+
1112
person :: Person
1213
person = Person "John Smith" 30
1314

14-
main = trace (showPerson person)
15+
main = log (showPerson person)

‎examples/arrays.purs

Lines changed: 0 additions & 11 deletions
This file was deleted.

‎examples/default.purs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Main where
22

3-
import Debug.Trace
3+
import Prelude
4+
import Control.Monad.Eff.Console (log)
45

5-
main = trace "Hello, World!"
6+
main = log "Hello, World!"

0 commit comments

Comments
 (0)