a5566d8 · rowtype-yoga/purescript-native

examples/passing/EmptyDataDecls.purs+3−4

compare with golang

unifiedsplit

@@ -25,7 +25,6 @@ foreign import error

25 \ throw msg;\

26 \}" :: forall a. String -> a

27

28−main = let (Array xs) = cons 1 $ cons 2 $ cons 3 nil

28+main = case cons 1 $ cons 2 $ cons 3 nil of

29− in if xs == [1, 2, 3]

30− then Debug.Trace.trace "Done"

29+ Array [1, 2, 3] -> Debug.Trace.trace "Done"

31− else error "Failed"

30+ _ -> error "Failed"

examples/passing/Let.purs+38−6

@@ -2,25 +2,57 @@ module Main where

2

3import Prelude

4import Control.Monad.Eff

5+import Control.Monad.ST

5

6

6−test1 x = let y = x + 1 in y

7+test1 x = let

8+ y :: Number

9+ y = x + 1

10+ in y

7

11

8test2 x y =

12test2 x y =

9 let x' = x + 1 in

13 let x' = x + 1 in

10 let y' = y + 1 in

14 let y' = y + 1 in

11 x' + y'

15 x' + y'

12

16

13−test3 x = let 1 = x in 2

14−

15−test4 = let f x y z = x + y + z in

17+test3 = let f x y z = x + y + z in

16 f 1 2 3

18 f 1 2 3

17

19

18−test5 = let f x [y, z] = x y z in

20+test4 = let f x [y, z] = x y z in

19 f (+) [1, 2]

21 f (+) [1, 2]

20

22

23+test5 = let

24+ f x | x > 0 = g (x / 2) + 1

25+ f x = 0

26+ g x = f (x - 1) + 1

27+ in g 10

28+

29+test6 = runPure (runST (do

30+ r <- newSTRef 0

31+ (let

32+ go [] = readSTRef r

33+ go (n : ns) = do

34+ modifySTRef r ((+) n)

35+ go ns

36+ in go [1, 2, 3, 4, 5])

37+ ))

38+

39+test7 = let

40+ f :: forall a. a -> a

41+ f x = x

42+ in if f true then f 1 else f 2

43+

44+test8 :: Number -> Number

45+test8 x = let

46+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

47+ go y = go $ (y + x / y) / 2

48+ in go x

49+

21main = do

50main = do

22 Debug.Trace.print (test1 1)

51 Debug.Trace.print (test1 1)

23 Debug.Trace.print (test2 1 2)

52 Debug.Trace.print (test2 1 2)

24− Debug.Trace.print (test3 1)

53+ Debug.Trace.print test3

25 Debug.Trace.print test4

54 Debug.Trace.print test4

26 Debug.Trace.print test5

55 Debug.Trace.print test5

56+ Debug.Trace.print test6

57+ Debug.Trace.print test7

58+ Debug.Trace.print (test8 100)

examples/passing/MonadState.purs+2−2

@@ -14,8 +14,8 @@ runState s (State f) = f s

14

15instance monadState :: Prelude.Monad (State s) where

16 return a = State $ \s -> Tuple s a

17− (>>=) f g = State $ \s -> let (Tuple s1 a) = runState s f in

17+ (>>=) f g = State $ \s -> case runState s f of

18− runState s1 (g a)

18+ Tuple s1 a -> runState s1 (g a)

19

20instance monadStateState :: MonadState s (State s) where

21 get = State (\s -> Tuple s s)

psci/Main.hs−1

@@ -161,7 +161,6 @@ quitMessage = "See ya!"

161

162-- |

163-- Loads module, function, and file completions.

164−-- TODO: filter names to only include exported decls

165--

164--

166completion :: CompletionFunc (StateT PSCiState IO)

165completion :: CompletionFunc (StateT PSCiState IO)

167completion = completeWord Nothing " \t\n\r" findCompletions

166completion = completeWord Nothing " \t\n\r" findCompletions

psci/Parser.hs+2−2

@@ -26,6 +26,7 @@ import Control.Applicative hiding (many)

26import Text.Parsec hiding ((<|>))

27

28import qualified Language.PureScript as P

29+import qualified Language.PureScript.Parser.Common as C (mark, same)

29

30

30-- |

31-- |

31-- PSCI version of @let@.

32-- PSCI version of @let@.

@@ -34,8 +35,7 @@ import qualified Language.PureScript as P

34-- we actually want the normal @let@.

35-- we actually want the normal @let@.

35--

36--

36psciLet :: Parsec String P.ParseState Command

37psciLet :: Parsec String P.ParseState Command

37−psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> (Left <$> P.parseBinder))

38+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C.same *> P.parseDeclaration))))

38− <*> (P.indented *> P.reservedOp "=" *> P.parseValue))

39

40-- |

41-- Parses PSCI metacommands or expressions input from the user.

purescript.cabal+1−3

@@ -33,8 +33,8 @@ library

33 Language.PureScript.Kinds

34 Language.PureScript.Names

35 Language.PureScript.Types

36− Language.PureScript.Values

37 Language.PureScript.Scope

36 Language.PureScript.Scope

37+ Language.PureScript.TypeClassDictionaries

38 Language.PureScript.DeadCodeElimination

39 Language.PureScript.Sugar

40 Language.PureScript.ModuleDependencies

@@ -44,7 +44,6 @@ library

44 Language.PureScript.Sugar.BindingGroups

45 Language.PureScript.Sugar.Operators

46 Language.PureScript.Sugar.TypeClasses

47− Language.PureScript.Sugar.Let

48 Language.PureScript.Sugar.Names

47 Language.PureScript.Sugar.Names

49 Language.PureScript.CodeGen

48 Language.PureScript.CodeGen

50 Language.PureScript.CodeGen.Common

49 Language.PureScript.CodeGen.Common

@@ -65,7 +64,6 @@ library

65 Language.PureScript.Parser.Kinds

64 Language.PureScript.Parser.Kinds

66 Language.PureScript.Parser.State

65 Language.PureScript.Parser.State

67 Language.PureScript.Parser.Types

66 Language.PureScript.Parser.Types

68− Language.PureScript.Parser.Values

69 Language.PureScript.Pretty

67 Language.PureScript.Pretty

70 Language.PureScript.Pretty.Common

68 Language.PureScript.Pretty.Common

71 Language.PureScript.Pretty.JS

69 Language.PureScript.Pretty.JS

src/Language/PureScript.hs−1

@@ -15,7 +15,6 @@

15

16module Language.PureScript (module P, compile, compile', MonadMake(..), make) where

17

18−import Language.PureScript.Values as P

19import Language.PureScript.Types as P

18import Language.PureScript.Types as P

20import Language.PureScript.Kinds as P

19import Language.PureScript.Kinds as P

21import Language.PureScript.Declarations as P

20import Language.PureScript.Declarations as P

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -24,10 +24,10 @@ import qualified Data.Map as M

24

25import Control.Monad.Writer

26

27+import Language.PureScript.TypeClassDictionaries

27import Language.PureScript.Declarations

28import Language.PureScript.Declarations

28import Language.PureScript.Pretty

29import Language.PureScript.Pretty

29import Language.PureScript.Names

30import Language.PureScript.Names

30−import Language.PureScript.Values

31import Language.PureScript.Environment

32

33-- |

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -30,7 +30,6 @@ import Control.Monad (replicateM, forM)

30

31import qualified Data.Map as M

32

33−import Language.PureScript.Values

34import Language.PureScript.Names

33import Language.PureScript.Names

35import Language.PureScript.Scope

34import Language.PureScript.Scope

36import Language.PureScript.Declarations

35import Language.PureScript.Declarations

@@ -134,6 +133,7 @@ valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (va

134valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

133valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

135valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

134valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

136valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]

135valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]

136+valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []

137valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])

138valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

139valueToJs _ m _ (Var ident) = varToJs m ident

src/Language/PureScript/DeadCodeElimination.hs−1

@@ -23,7 +23,6 @@ import Data.Generics

23import Data.Maybe (mapMaybe)

24

25import Language.PureScript.Names

26−import Language.PureScript.Values

27import Language.PureScript.Declarations

26import Language.PureScript.Declarations

28

27

29-- |

28-- |

src/Language/PureScript/Declarations.hs+192−1

@@ -16,14 +16,15 @@

16

17module Language.PureScript.Declarations where

18

19−import Language.PureScript.Values

20import Language.PureScript.Types

19import Language.PureScript.Types

21import Language.PureScript.Names

20import Language.PureScript.Names

22import Language.PureScript.Kinds

21import Language.PureScript.Kinds

22+import Language.PureScript.TypeClassDictionaries

23import Language.PureScript.CodeGen.JS.AST

24import Language.PureScript.Environment

25

26import qualified Data.Data as D

27+import Data.Generics (mkQ, everything)

27

28

28-- |

29-- |

29-- A precedence level for an infix operator

30-- A precedence level for an infix operator

@@ -190,3 +191,193 @@ isTypeClassDeclaration :: Declaration -> Bool

190isTypeClassDeclaration TypeClassDeclaration{} = True

191isTypeClassDeclaration TypeClassDeclaration{} = True

191isTypeClassDeclaration TypeInstanceDeclaration{} = True

192isTypeClassDeclaration TypeInstanceDeclaration{} = True

192isTypeClassDeclaration _ = False

193isTypeClassDeclaration _ = False

194+

195+-- |

196+-- A guard is just a boolean-valued expression that appears alongside a set of binders

197+--

198+type Guard = Value

199+

200+-- |

201+-- Data type for values

202+--

203+data Value

204+ -- |

205+ -- A numeric literal

206+ --

207+ = NumericLiteral (Either Integer Double)

208+ -- |

209+ -- A string literal

210+ --

211+ | StringLiteral String

212+ -- |

213+ -- A boolean literal

214+ --

215+ | BooleanLiteral Bool

216+ -- |

217+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

218+ -- will be removed.

219+ --

220+ | BinaryNoParens (Qualified Ident) Value Value

221+ -- |

222+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

223+ -- will be removed.

224+ --

225+ | Parens Value

226+ -- |

227+ -- An array literal

228+ --

229+ | ArrayLiteral [Value]

230+ -- |

231+ -- An object literal

232+ --

233+ | ObjectLiteral [(String, Value)]

234+ -- |

235+ -- An record property accessor expression

236+ --

237+ | Accessor String Value

238+ -- |

239+ -- Partial record update

240+ --

241+ | ObjectUpdate Value [(String, Value)]

242+ -- |

243+ -- Function introduction

244+ --

245+ | Abs (Either Ident Binder) Value

246+ -- |

247+ -- Function application

248+ --

249+ | App Value Value

250+ -- |

251+ -- Variable

252+ --

253+ | Var (Qualified Ident)

254+ -- |

255+ -- Conditional (if-then-else expression)

256+ --

257+ | IfThenElse Value Value Value

258+ -- |

259+ -- A data constructor

260+ --

261+ | Constructor (Qualified ProperName)

262+ -- |

263+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get

264+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

265+ --

266+ | Case [Value] [CaseAlternative]

267+ -- |

268+ -- A value with a type annotation

269+ --

270+ | TypedValue Bool Value Type

271+ -- |

272+ -- A let binding

273+ --

274+ | Let [Declaration] Value

275+ -- |

276+ -- A do-notation block

277+ --

278+ | Do [DoNotationElement]

279+ -- |

280+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

281+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which

282+ -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

283+ -- instance type, and the type class dictionaries in scope.

284+ --

285+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, D.Data, D.Typeable)

286+

287+-- |

288+-- An alternative in a case statement

289+--

290+data CaseAlternative = CaseAlternative

291+ { -- |

292+ -- A collection of binders with which to match the inputs

293+ --

294+ caseAlternativeBinders :: [Binder]

295+ -- |

296+ -- An optional guard

297+ --

298+ , caseAlternativeGuard :: Maybe Guard

299+ -- |

300+ -- The result expression

301+ --

302+ , caseAlternativeResult :: Value

303+ } deriving (Show, D.Data, D.Typeable)

304+

305+-- |

306+-- Find the original dictionary which a type class dictionary in scope refers to

307+--

308+canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

309+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

310+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

311+

312+-- |

313+-- A statement in a do-notation block

314+--

315+data DoNotationElement

316+ -- |

317+ -- A monadic value without a binder

318+ --

319+ = DoNotationValue Value

320+ -- |

321+ -- A monadic value with a binder

322+ --

323+ | DoNotationBind Binder Value

324+ -- |

325+ -- A let statement, i.e. a pure value with a binder

326+ --

327+ | DoNotationLet Binder Value deriving (Show, D.Data, D.Typeable)

328+

329+-- |

330+-- Data type for binders

331+--

332+data Binder

333+ -- |

334+ -- Wildcard binder

335+ --

336+ = NullBinder

337+ -- |

338+ -- A binder which matches a boolean literal

339+ --

340+ | BooleanBinder Bool

341+ -- |

342+ -- A binder which matches a string literal

343+ --

344+ | StringBinder String

345+ -- |

346+ -- A binder which matches a numeric literal

347+ --

348+ | NumberBinder (Either Integer Double)

349+ -- |

350+ -- A binder which binds an identifier

351+ --

352+ | VarBinder Ident

353+ -- |

354+ -- A binder which matches a data constructor

355+ --

356+ | ConstructorBinder (Qualified ProperName) [Binder]

357+ -- |

358+ -- A binder which matches a record and binds its properties

359+ --

360+ | ObjectBinder [(String, Binder)]

361+ -- |

362+ -- A binder which matches an array and binds its elements

363+ --

364+ | ArrayBinder [Binder]

365+ -- |

366+ -- A binder which matches an array and binds its head and tail

367+ --

368+ | ConsBinder Binder Binder

369+ -- |

370+ -- A binder which binds its input to an identifier

371+ --

372+ | NamedBinder Ident Binder deriving (Show, D.Data, D.Typeable)

373+

374+

375+-- |

376+-- Collect all names introduced in binders in an expression

377+--

378+binderNames :: (D.Data d) => d -> [Ident]

379+binderNames = everything (++) (mkQ [] go)

380+ where

381+ go (VarBinder ident) = [ident]

382+ go (NamedBinder ident _) = [ident]

383+ go _ = []

src/Language/PureScript/Environment.hs+1−1

@@ -21,7 +21,7 @@ import Data.Data

21import Language.PureScript.Names

22import Language.PureScript.Types

23import Language.PureScript.Kinds

24−import Language.PureScript.Values

24+import Language.PureScript.TypeClassDictionaries

25import qualified Language.PureScript.Constants as C

26

27import qualified Data.Map as M

src/Language/PureScript/Optimizer/MagicDo.hs+12−7

@@ -58,12 +58,14 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

58 convert :: JS -> JS

59 -- Desugar return

60 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

61− -- Desugae >>

61+ -- Desugar >>

62− convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =

62+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =

63+ let JSReturn ret = last js in

63− JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]

64+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )

64 -- Desugar >>=

65 -- Desugar >>=

65− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =

66+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =

67+ let JSReturn ret = last js in

66− JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]

68+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )

67 -- Desugar untilE

69 -- Desugar untilE

68 convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

70 convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

69 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []

71 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []

@@ -109,6 +111,9 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

109 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

111 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

110 undo other = other

112 undo other = other

111

113

114+ isJSReturn (JSReturn _) = True

115+ isJSReturn _ = False

116+

112-- |

117-- |

113-- Inline functions in the ST module

118-- Inline functions in the ST module

114--

119--

@@ -128,8 +133,8 @@ inlineST = everywhere (mkT convertBlock)

128 -- Convert a block in a safe way, preserving object wrappers of references,

133 -- Convert a block in a safe way, preserving object wrappers of references,

129 -- or in a more aggressive way, turning wrappers into local variables depending on the

134 -- or in a more aggressive way, turning wrappers into local variables depending on the

130 -- agg(ressive) parameter.

135 -- agg(ressive) parameter.

131− convert agg (JSApp (JSApp f [arg]) []) | isSTFunc C.newSTRef f =

136+ convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =

132− if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]

137+ JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])

133 convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =

138 convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =

134 if agg then ref else JSAccessor C.stRefValue ref

139 if agg then ref else JSAccessor C.stRefValue ref

135 convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

140 convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

src/Language/PureScript/Parser.hs−1

@@ -29,7 +29,6 @@ module Language.PureScript.Parser (module P) where

29

30import Language.PureScript.Parser.Common as P

31import Language.PureScript.Parser.Types as P

32−import Language.PureScript.Parser.Values as P

33import Language.PureScript.Parser.State as P

32import Language.PureScript.Parser.State as P

34import Language.PureScript.Parser.Kinds as P

33import Language.PureScript.Parser.Kinds as P

35import Language.PureScript.Parser.Declarations as P

34import Language.PureScript.Parser.Declarations as P

src/Language/PureScript/Parser/Declarations.hs+224−6

@@ -16,26 +16,27 @@

16module Language.PureScript.Parser.Declarations (

17 parseDeclaration,

18 parseModule,

19− parseModules

19+ parseModules,

20+ parseValue,

21+ parseGuard,

22+ parseBinder,

23+ parseBinderNoParens,

20) where

24) where

21

25

22import Data.Maybe (isJust, fromMaybe)

26import Data.Maybe (isJust, fromMaybe)

23import Control.Applicative

27import Control.Applicative

24−import qualified Text.Parsec as P

25

28

26import Language.PureScript.Parser.State

29import Language.PureScript.Parser.State

27import Language.PureScript.Parser.Common

30import Language.PureScript.Parser.Common

28import Language.PureScript.Declarations

31import Language.PureScript.Declarations

29−import Language.PureScript.Parser.Values

30import Language.PureScript.Parser.Types

32import Language.PureScript.Parser.Types

31import Language.PureScript.Parser.Kinds

33import Language.PureScript.Parser.Kinds

32import Language.PureScript.CodeGen.JS.AST

34import Language.PureScript.CodeGen.JS.AST

33import Language.PureScript.Environment

35import Language.PureScript.Environment

34

36

35−import qualified Text.Parsec.Expr as P

36−

37import qualified Language.PureScript.Parser.Common as C

38import qualified Text.Parsec as P

39+import qualified Text.Parsec.Expr as P

39

40

40parseDataDeclaration :: P.Parsec String ParseState Declaration

41parseDataDeclaration :: P.Parsec String ParseState Declaration

41parseDataDeclaration = do

42parseDataDeclaration = do

@@ -165,7 +166,14 @@ parseDeclaration = P.choice

165 , parseFixityDeclaration

166 , parseFixityDeclaration

166 , parseImportDeclaration

167 , parseImportDeclaration

167 , parseTypeClassDeclaration

168 , parseTypeClassDeclaration

168− , parseTypeInstanceDeclaration ] P.<?> "declaration"

169+ , parseTypeInstanceDeclaration

170+ ] P.<?> "declaration"

171+

172+parseLocalDeclaration :: P.Parsec String ParseState Declaration

173+parseLocalDeclaration = P.choice

174+ [ parseTypeDeclaration

175+ , parseValueDeclaration

176+ ] P.<?> "local declaration"

169

177

170-- |

178-- |

171-- Parse a module header and a collection of declarations

179-- Parse a module header and a collection of declarations

@@ -185,3 +193,213 @@ parseModule = do

185--

193--

186parseModules :: P.Parsec String ParseState [Module]

194parseModules :: P.Parsec String ParseState [Module]

187parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

195parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

196+

197+booleanLiteral :: P.Parsec String ParseState Bool

198+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

199+

200+parseNumericLiteral :: P.Parsec String ParseState Value

201+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat

202+

203+parseStringLiteral :: P.Parsec String ParseState Value

204+parseStringLiteral = StringLiteral <$> C.stringLiteral

205+

206+parseBooleanLiteral :: P.Parsec String ParseState Value

207+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

208+

209+parseArrayLiteral :: P.Parsec String ParseState Value

210+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)

211+

212+parseObjectLiteral :: P.Parsec String ParseState Value

213+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

214+

215+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

216+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)

217+ <*> (C.indented *> parseValue)

218+

219+parseAbs :: P.Parsec String ParseState Value

220+parseAbs = do

221+ C.reservedOp "\\"

222+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

223+ C.indented *> C.reservedOp "->"

224+ value <- parseValue

225+ return $ toFunction args value

226+ where

227+ toFunction :: [Value -> Value] -> Value -> Value

228+ toFunction args value = foldr ($) value args

229+

230+parseVar :: P.Parsec String ParseState Value

231+parseVar = Var <$> C.parseQualified C.parseIdent

232+

233+parseConstructor :: P.Parsec String ParseState Value

234+parseConstructor = Constructor <$> C.parseQualified C.properName

235+

236+parseCase :: P.Parsec String ParseState Value

237+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

238+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

239+

240+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

241+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

242+ <*> P.optionMaybe parseGuard

243+ <*> (C.indented *> C.reservedOp "->" *> parseValue)

244+ P.<?> "case alternative"

245+

246+parseIfThenElse :: P.Parsec String ParseState Value

247+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

248+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

249+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

250+

251+parseLet :: P.Parsec String ParseState Value

252+parseLet = do

253+ C.reserved "let"

254+ C.indented

255+ ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)

256+ C.indented

257+ C.reserved "in"

258+ result <- parseValue

259+ return $ Let ds result

260+

261+parseValueAtom :: P.Parsec String ParseState Value

262+parseValueAtom = P.choice

263+ [ P.try parseNumericLiteral

264+ , P.try parseStringLiteral

265+ , P.try parseBooleanLiteral

266+ , parseArrayLiteral

267+ , P.try parseObjectLiteral

268+ , parseAbs

269+ , P.try parseConstructor

270+ , P.try parseVar

271+ , parseCase

272+ , parseIfThenElse

273+ , parseDo

274+ , parseLet

275+ , Parens <$> C.parens parseValue ]

276+

277+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

278+parsePropertyUpdate = do

279+ name <- C.lexeme C.identifier

280+ _ <- C.lexeme $ C.indented *> P.char '='

281+ value <- C.indented *> parseValue

282+ return (name, value)

283+

284+parseAccessor :: Value -> P.Parsec String ParseState Value

285+parseAccessor (Constructor _) = P.unexpected "constructor"

286+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

287+

288+parseDo :: P.Parsec String ParseState Value

289+parseDo = do

290+ C.reserved "do"

291+ C.indented

292+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))

293+

294+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

295+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)

296+ <*> (C.indented *> C.reservedOp "=" *> parseValue)

297+

298+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

299+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)

300+

301+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

302+parseDoNotationElement = P.choice

303+ [ P.try parseDoNotationBind

304+ , parseDoNotationLet

305+ , P.try (DoNotationValue <$> parseValue) ]

306+

307+-- |

308+-- Parse a value

309+--

310+parseValue :: P.Parsec String ParseState Value

311+parseValue =

312+ (P.buildExpressionParser operators

313+ . C.buildPostfixParser postfixTable2

314+ $ indexersAndAccessors) P.<?> "expression"

315+ where

316+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

317+ postfixTable1 = [ parseAccessor

318+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

319+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

320+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

321+ ]

322+ operators = [ [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

323+ return (BinaryNoParens ident))) P.AssocRight ]

324+ ]

325+

326+parseStringBinder :: P.Parsec String ParseState Binder

327+parseStringBinder = StringBinder <$> C.stringLiteral

328+

329+parseBooleanBinder :: P.Parsec String ParseState Binder

330+parseBooleanBinder = BooleanBinder <$> booleanLiteral

331+

332+parseNumberBinder :: P.Parsec String ParseState Binder

333+parseNumberBinder = NumberBinder <$> C.integerOrFloat

334+

335+parseVarBinder :: P.Parsec String ParseState Binder

336+parseVarBinder = VarBinder <$> C.parseIdent

337+

338+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder

339+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []

340+

341+parseConstructorBinder :: P.Parsec String ParseState Binder

342+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)

343+

344+parseObjectBinder :: P.Parsec String ParseState Binder

345+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

346+

347+parseArrayBinder :: P.Parsec String ParseState Binder

348+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)

349+

350+parseNamedBinder :: P.Parsec String ParseState Binder

351+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

352+ <*> (C.indented *> parseBinder)

353+

354+parseNullBinder :: P.Parsec String ParseState Binder

355+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder

356+

357+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

358+parseIdentifierAndBinder = do

359+ name <- C.lexeme C.identifier

360+ _ <- C.lexeme $ C.indented *> P.char '='

361+ binder <- C.indented *> parseBinder

362+ return (name, binder)

363+

364+-- |

365+-- Parse a binder

366+--

367+parseBinder :: P.Parsec String ParseState Binder

368+parseBinder = P.buildExpressionParser operators parseBinderAtom P.<?> "expression"

369+ where

370+ operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]

371+ parseBinderAtom :: P.Parsec String ParseState Binder

372+ parseBinderAtom = P.choice (map P.try

373+ [ parseNullBinder

374+ , parseStringBinder

375+ , parseBooleanBinder

376+ , parseNumberBinder

377+ , parseNamedBinder

378+ , parseVarBinder

379+ , parseConstructorBinder

380+ , parseObjectBinder

381+ , parseArrayBinder

382+ , C.parens parseBinder ]) P.<?> "binder"

383+

384+-- |

385+-- Parse a binder as it would appear in a top level declaration

386+--

387+parseBinderNoParens :: P.Parsec String ParseState Binder

388+parseBinderNoParens = P.choice (map P.try

389+ [ parseNullBinder

390+ , parseStringBinder

391+ , parseBooleanBinder

392+ , parseNumberBinder

393+ , parseNamedBinder

394+ , parseVarBinder

395+ , parseNullaryConstructorBinder

396+ , parseObjectBinder

397+ , parseArrayBinder

398+ , C.parens parseBinder ]) P.<?> "binder"

399+-- |

400+-- Parse a guard

401+--

402+parseGuard :: P.Parsec String ParseState Guard

403+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue

404+

405+

src/Language/PureScript/Parser/Values.hsdeleted−246

@@ -1,246 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Parser.Values

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Parsers for values, statements, binders and guards

13−--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.Parser.Values (

17− parseValue,

18− parseGuard,

19− parseBinder,

20− parseBinderNoParens,

21−) where

22−

23−import Control.Applicative

24−

25−import Language.PureScript.Values

26−import Language.PureScript.Parser.State

27−import Language.PureScript.Parser.Types

28−

29−import Text.Parsec.Expr

30−

31−import qualified Language.PureScript.Parser.Common as C

32−import qualified Text.Parsec as P

33−

34−booleanLiteral :: P.Parsec String ParseState Bool

35−booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

36−

37−parseNumericLiteral :: P.Parsec String ParseState Value

38−parseNumericLiteral = NumericLiteral <$> C.integerOrFloat

39−

40−parseStringLiteral :: P.Parsec String ParseState Value

41−parseStringLiteral = StringLiteral <$> C.stringLiteral

42−

43−parseBooleanLiteral :: P.Parsec String ParseState Value

44−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

45−

46−parseArrayLiteral :: P.Parsec String ParseState Value

47−parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)

48−

49−parseObjectLiteral :: P.Parsec String ParseState Value

50−parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

51−

52−parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

53−parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)

54− <*> (C.indented *> parseValue)

55−

56−parseAbs :: P.Parsec String ParseState Value

57−parseAbs = do

58− C.reservedOp "\\"

59− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

60− C.indented *> C.reservedOp "->"

61− value <- parseValue

62− return $ toFunction args value

63− where

64− toFunction :: [Value -> Value] -> Value -> Value

65− toFunction args value = foldr ($) value args

66−

67−parseVar :: P.Parsec String ParseState Value

68−parseVar = Var <$> C.parseQualified C.parseIdent

69−

70−parseConstructor :: P.Parsec String ParseState Value

71−parseConstructor = Constructor <$> C.parseQualified C.properName

72−

73−parseCase :: P.Parsec String ParseState Value

74−parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

75− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

76−

77−parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

78−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

79− <*> P.optionMaybe parseGuard

80− <*> (C.indented *> C.reservedOp "->" *> parseValue)

81− P.<?> "case alternative"

82−

83−parseIfThenElse :: P.Parsec String ParseState Value

84−parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

85− <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

86− <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

87−

88−parseLet :: P.Parsec String ParseState Value

89−parseLet = do

90− C.reserved "let"

91− C.indented

92− binder <- P.try (Right <$> ((,) <$> C.parseIdent <*> P.many (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

93− <|> (Left <$> parseBinder)

94− C.indented

95− C.reservedOp "="

96− C.indented

97− value <- parseValue

98− C.indented

99− C.reserved "in"

100− result <- parseValue

101− return $ Let binder value result

102−

103−parseValueAtom :: P.Parsec String ParseState Value

104−parseValueAtom = P.choice

105− [ P.try parseNumericLiteral

106− , P.try parseStringLiteral

107− , P.try parseBooleanLiteral

108− , parseArrayLiteral

109− , P.try parseObjectLiteral

110− , parseAbs

111− , P.try parseConstructor

112− , P.try parseVar

113− , parseCase

114− , parseIfThenElse

115− , parseDo

116− , parseLet

117− , Parens <$> C.parens parseValue ]

118−

119−parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

120−parsePropertyUpdate = do

121− name <- C.lexeme C.identifier

122− _ <- C.lexeme $ C.indented *> P.char '='

123− value <- C.indented *> parseValue

124− return (name, value)

125−

126−parseAccessor :: Value -> P.Parsec String ParseState Value

127−parseAccessor (Constructor _) = P.unexpected "constructor"

128−parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

129−

130−parseDo :: P.Parsec String ParseState Value

131−parseDo = do

132− C.reserved "do"

133− C.indented

134− Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))

135−

136−parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

137−parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)

138− <*> (C.indented *> C.reservedOp "=" *> parseValue)

139−

140−parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

141−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)

142−

143−parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

144−parseDoNotationElement = P.choice

145− [ P.try parseDoNotationBind

146− , parseDoNotationLet

147− , P.try (DoNotationValue <$> parseValue) ]

148−

149−-- |

150−-- Parse a value

151−--

152−parseValue :: P.Parsec String ParseState Value

153−parseValue =

154− (buildExpressionParser operators

155− . C.buildPostfixParser postfixTable2

156− $ indexersAndAccessors) P.<?> "expression"

157− where

158− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

159− postfixTable1 = [ parseAccessor

160− , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

161− postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

162− , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

163− ]

164− operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

165− return (BinaryNoParens ident))) AssocRight ]

166− ]

167−

168−parseStringBinder :: P.Parsec String ParseState Binder

169−parseStringBinder = StringBinder <$> C.stringLiteral

170−

171−parseBooleanBinder :: P.Parsec String ParseState Binder

172−parseBooleanBinder = BooleanBinder <$> booleanLiteral

173−

174−parseNumberBinder :: P.Parsec String ParseState Binder

175−parseNumberBinder = NumberBinder <$> C.integerOrFloat

176−

177−parseVarBinder :: P.Parsec String ParseState Binder

178−parseVarBinder = VarBinder <$> C.parseIdent

179−

180−parseNullaryConstructorBinder :: P.Parsec String ParseState Binder

181−parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []

182−

183−parseConstructorBinder :: P.Parsec String ParseState Binder

184−parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)

185−

186−parseObjectBinder :: P.Parsec String ParseState Binder

187−parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

188−

189−parseArrayBinder :: P.Parsec String ParseState Binder

190−parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)

191−

192−parseNamedBinder :: P.Parsec String ParseState Binder

193−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

194− <*> (C.indented *> parseBinder)

195−

196−parseNullBinder :: P.Parsec String ParseState Binder

197−parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder

198−

199−parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

200−parseIdentifierAndBinder = do

201− name <- C.lexeme C.identifier

202− _ <- C.lexeme $ C.indented *> P.char '='

203− binder <- C.indented *> parseBinder

204− return (name, binder)

205−

206−-- |

207−-- Parse a binder

208−--

209−parseBinder :: P.Parsec String ParseState Binder

210−parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression"

211− where

212− operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

213− parseBinderAtom :: P.Parsec String ParseState Binder

214− parseBinderAtom = P.choice (map P.try

215− [ parseNullBinder

216− , parseStringBinder

217− , parseBooleanBinder

218− , parseNumberBinder

219− , parseNamedBinder

220− , parseVarBinder

221− , parseConstructorBinder

222− , parseObjectBinder

223− , parseArrayBinder

224− , C.parens parseBinder ]) P.<?> "binder"

225−

226−-- |

227−-- Parse a binder as it would appear in a top level declaration

228−--

229−parseBinderNoParens :: P.Parsec String ParseState Binder

230−parseBinderNoParens = P.choice (map P.try

231− [ parseNullBinder

232− , parseStringBinder

233− , parseBooleanBinder

234− , parseNumberBinder

235− , parseNamedBinder

236− , parseVarBinder

237− , parseNullaryConstructorBinder

238− , parseObjectBinder

239− , parseArrayBinder

240− , C.parens parseBinder ]) P.<?> "binder"

241−-- |

242−-- Parse a guard

243−--

244−parseGuard :: P.Parsec String ParseState Guard

245−parseGuard = C.indented *> C.pipe *> C.indented *> parseValue

246−

src/Language/PureScript/Pretty/Values.hs+2−1

@@ -24,7 +24,7 @@ import Control.Arrow ((<+>))

24import Control.PatternArrows

25

26import Language.PureScript.Types

27−import Language.PureScript.Values

27+import Language.PureScript.Declarations

28import Language.PureScript.Pretty.Common

29import Language.PureScript.Pretty.Types

30

@@ -40,6 +40,7 @@ literals = mkPattern match

40 match (Constructor name) = Just $ show name

41 match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++

42 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

43+ match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val

43 match (Var ident) = Just $ show ident

44 match (Var ident) = Just $ show ident

44 match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

45 match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

45 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

46 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

src/Language/PureScript/Scope.hs+1−1

@@ -24,7 +24,7 @@ import Data.Data

24import Data.List ((\\), nub)

25import Data.Generics (extQ, mkQ, everything)

26

27−import Language.PureScript.Values

27+import Language.PureScript.Declarations

28import Language.PureScript.Names

29import Language.PureScript.CodeGen.JS.AST

30

src/Language/PureScript/Sugar.hs+2−7

@@ -16,7 +16,6 @@

16module Language.PureScript.Sugar (desugar, module S) where

17

18import Control.Monad

19−import Control.Arrow ((>>>))

20

19

21import Language.PureScript.Declarations

20import Language.PureScript.Declarations

22

21

@@ -26,14 +25,11 @@ import Language.PureScript.Sugar.CaseDeclarations as S

26import Language.PureScript.Sugar.TypeDeclarations as S

25import Language.PureScript.Sugar.TypeDeclarations as S

27import Language.PureScript.Sugar.BindingGroups as S

26import Language.PureScript.Sugar.BindingGroups as S

28import Language.PureScript.Sugar.TypeClasses as S

27import Language.PureScript.Sugar.TypeClasses as S

29−import Language.PureScript.Sugar.Let as S

30import Language.PureScript.Sugar.Names as S

28import Language.PureScript.Sugar.Names as S

31

29

32-- |

30-- |

33-- The desugaring pipeline proceeds as follows:

31-- The desugaring pipeline proceeds as follows:

34--

32--

35−-- * Desugar let bindings

36−--

37-- * Introduce type synonyms for type class dictionaries

33-- * Introduce type synonyms for type class dictionaries

38--

34--

39-- * Rebracket user-defined binary operators

35-- * Rebracket user-defined binary operators

@@ -50,10 +46,9 @@ import Language.PureScript.Sugar.Names as S

50--

46--

51desugar :: [Module] -> Either String [Module]

47desugar :: [Module] -> Either String [Module]

52desugar = desugarDo

48desugar = desugarDo

53− >=> desugarLetBindings

49+ >=> desugarCasesModule

54− >>> desugarCasesModule

50+ >=> desugarTypeDeclarationsModule

55 >=> desugarImports

51 >=> desugarImports

56 >=> rebracket

52 >=> rebracket

57− >=> desugarTypeDeclarationsModule

58 >=> desugarTypeClasses

53 >=> desugarTypeClasses

59 >=> createBindingGroupsModule

54 >=> createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+14−4

@@ -24,13 +24,13 @@ module Language.PureScript.Sugar.BindingGroups (

24import Data.Data

25import Data.Graph

26import Data.Generics

27+import Data.Generics.Extras

27import Data.List (nub, intersect)

28import Data.List (nub, intersect)

28import Data.Maybe (mapMaybe)

29import Data.Maybe (mapMaybe)

29import Control.Applicative ((<$>), (<*>), pure)

30import Control.Applicative ((<$>), (<*>), pure)

30

31

31import Language.PureScript.Declarations

32import Language.PureScript.Declarations

32import Language.PureScript.Names

33import Language.PureScript.Names

33−import Language.PureScript.Values

34import Language.PureScript.Types

35import Language.PureScript.Environment

36

@@ -51,8 +51,8 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla

51--

52createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]

53createBindingGroups moduleName ds = do

54− let values = filter isValueDecl ds

54+ values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds

55− dataDecls = filter isDataDecl ds

55+ let dataDecls = filter isDataDecl ds

56 allProperNames = map getProperName dataDecls

57 dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

58 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

@@ -68,16 +68,26 @@ createBindingGroups moduleName ds = do

68 filter isExternDecl ds ++

69 bindingGroupDecls

70

71+createBindingGroupsForValue :: ModuleName -> Declaration -> Either String Declaration

72+createBindingGroupsForValue moduleName = everywhereM' (mkM go)

73+ where

74+ go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val

75+ go other = return other

76+

71-- |

77-- |

72-- Collapse all binding groups to individual declarations

78-- Collapse all binding groups to individual declarations

73--

79--

74collapseBindingGroups :: [Declaration] -> [Declaration]

80collapseBindingGroups :: [Declaration] -> [Declaration]

75−collapseBindingGroups = concatMap go

81+collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatMap go

76 where

82 where

77 go (DataBindingGroupDeclaration ds) = ds

83 go (DataBindingGroupDeclaration ds) = ds

78 go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds

84 go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds

79 go other = [other]

85 go other = [other]

80

86

87+collapseBindingGroupsForValue :: Value -> Value

88+collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

89+collapseBindingGroupsForValue other = other

90+

81usedIdents :: (Data d) => ModuleName -> d -> [Ident]

91usedIdents :: (Data d) => ModuleName -> d -> [Ident]

82usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

92usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

83 where

93 where

src/Language/PureScript/Sugar/CaseDeclarations.hs+7−2

@@ -20,14 +20,14 @@ module Language.PureScript.Sugar.CaseDeclarations (

20) where

21

22import Data.List (groupBy)

23−import Data.Generics (mkT, everywhere)

23+import Data.Generics (mkM, mkT, everywhere)

24+import Data.Generics.Extras

24

25

25import Control.Applicative

26import Control.Applicative

26import Control.Monad ((<=<), forM, join, unless)

27import Control.Monad ((<=<), forM, join, unless)

27import Control.Monad.Error.Class

28import Control.Monad.Error.Class

28

29

29import Language.PureScript.Names

30import Language.PureScript.Names

30−import Language.PureScript.Values

31import Language.PureScript.Declarations

32import Language.PureScript.Scope

33import Language.PureScript.Environment

@@ -57,6 +57,11 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

57 desugarRest :: [Declaration] -> Either String [Declaration]

58 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

59 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

60+ desugarRest (ValueDeclaration name nameKind bs g val : rest) = do

61+ (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarRest rest

62+ where

63+ go (Let ds val') = Let <$> desugarCases ds <*> pure val'

64+ go other = return other

60 desugarRest (d : ds) = (:) d <$> desugarRest ds

65 desugarRest (d : ds) = (:) d <$> desugarRest ds

61 desugarRest [] = pure []

66 desugarRest [] = pure []

62

67

src/Language/PureScript/Sugar/DoNotation.hs+1−1

@@ -21,9 +21,9 @@ module Language.PureScript.Sugar.DoNotation (

21import Data.Data

22import Data.Generics

23

24−import Language.PureScript.Values

25import Language.PureScript.Names

24import Language.PureScript.Names

26import Language.PureScript.Scope

25import Language.PureScript.Scope

26+import Language.PureScript.Declarations

27

28import qualified Language.PureScript.Constants as C

29

src/Language/PureScript/Sugar/Let.hsdeleted−34

@@ -1,34 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Let

4−-- Copyright : (c) Phil Freeman 2014

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the desugaring pass which turns let bindings into function applications.

13−--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.Sugar.Let (

17− desugarLetBindings

18−) where

19−

20−import Data.Generics (mkT, everywhere)

21−

22−import Language.PureScript.Values

23−import Language.PureScript.Declarations

24−

25−-- |

26−-- Turn let bindings into function applications

27−--

28−desugarLetBindings :: [Module] -> [Module]

29−desugarLetBindings = everywhere (mkT go)

30− where

31− go (Let (Left (VarBinder ident)) value result) = App (Abs (Left ident) result) value

32− go (Let (Left binder) value result) = Case [value] [CaseAlternative [binder] Nothing result]

33− go (Let (Right (ident, binders)) value result) = App (Abs (Left ident) result) (foldr Abs value binders)

34− go other = other

src/Language/PureScript/Sugar/Names.hs+8−2

@@ -28,7 +28,6 @@ import qualified Data.Map as M

28import Language.PureScript.Declarations

29import Language.PureScript.Names

30import Language.PureScript.Types

31−import Language.PureScript.Values

32import Language.PureScript.Environment

31import Language.PureScript.Environment

33

32

34-- |

33-- |

@@ -177,7 +176,7 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $

177--

176--

178renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

177renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

179renameInModule imports exports (Module mn decls exps) =

178renameInModule imports exports (Module mn decls exps) =

180− Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps

179+ Module mn <$> (mapM updateDecl decls >>= (mapM updateVars >=> everywhereM (mkM updateType `extM` updateValue `extM` updateBinder))) <*> pure exps

181 where

180 where

182 updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

181 updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

183 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

182 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

@@ -190,6 +189,8 @@ renameInModule imports exports (Module mn decls exps) =

190 ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

189 ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

191 where

190 where

192 bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')

191 bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')

192+ bindFunctionArgs bound (Let ds val') = let args = map letBoundVariable ds in

193+ return (args ++ bound, Let ds val')

193 bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

194 bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

194 (,) bound <$> (Var <$> updateValueName name')

195 (,) bound <$> (Var <$> updateValueName name')

195 bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =

196 bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =

@@ -201,7 +202,12 @@ renameInModule imports exports (Module mn decls exps) =

201 bindFunctionArgs bound other = return (bound, other)

202 bindFunctionArgs bound other = return (bound, other)

202 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

203 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

203 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

204 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

205+

206+ letBoundVariable :: Declaration -> Ident

207+ letBoundVariable (ValueDeclaration ident _ _ _ _) = ident

208+ letBoundVariable _ = error "Invalid argument to letBoundVariable"

204 updateVars (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name

209 updateVars (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name

210+ updateVars (TypeInstanceDeclaration name deps className tys ds) = TypeInstanceDeclaration name deps className tys <$> mapM updateVars ds

205 updateVars other = return other

211 updateVars other = return other

206 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

212 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

207 updateValue v = return v

213 updateValue v = return v

src/Language/PureScript/Sugar/Operators.hs−1

@@ -25,7 +25,6 @@ module Language.PureScript.Sugar.Operators (

25

26import Language.PureScript.Names

27import Language.PureScript.Declarations

28−import Language.PureScript.Values

29

28

30import Control.Applicative

29import Control.Applicative

31import Control.Monad.State

30import Control.Monad.State

src/Language/PureScript/Sugar/TypeClasses.hs−1

@@ -22,7 +22,6 @@ module Language.PureScript.Sugar.TypeClasses (

22import Language.PureScript.Declarations

23import Language.PureScript.Names

24import Language.PureScript.Types

25−import Language.PureScript.Values

26import Language.PureScript.CodeGen.JS.AST

25import Language.PureScript.CodeGen.JS.AST

27import Language.PureScript.Sugar.CaseDeclarations

26import Language.PureScript.Sugar.CaseDeclarations

28import Language.PureScript.Environment

27import Language.PureScript.Environment

src/Language/PureScript/Sugar/TypeDeclarations.hs+8−1

@@ -19,12 +19,14 @@ module Language.PureScript.Sugar.TypeDeclarations (

19 desugarTypeDeclarationsModule

20) where

21

22+import Data.Generics (mkM)

23+import Data.Generics.Extras

24+

22import Control.Applicative

25import Control.Applicative

23import Control.Monad.Error.Class

26import Control.Monad.Error.Class

24import Control.Monad (forM)

27import Control.Monad (forM)

25

28

26import Language.PureScript.Declarations

29import Language.PureScript.Declarations

27−import Language.PureScript.Values

28

30

29-- |

31-- |

30-- Replace all top level type declarations in a module with type annotations

32-- Replace all top level type declarations in a module with type annotations

@@ -39,5 +41,10 @@ desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

39desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =

41desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =

40 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

42 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

41desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

43desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

44+desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do

45+ (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

46+ where

47+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

48+ go other = return other

42desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

49desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

43desugarTypeDeclarations [] = return []

50desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker.hs+1−1

@@ -32,9 +32,9 @@ import Control.Monad.Error

32

33import Language.PureScript.Types

34import Language.PureScript.Names

35−import Language.PureScript.Values

36import Language.PureScript.Kinds

35import Language.PureScript.Kinds

37import Language.PureScript.Declarations

36import Language.PureScript.Declarations

37+import Language.PureScript.TypeClassDictionaries

38import Language.PureScript.Environment

39import Language.PureScript.Pretty.Types

40

src/Language/PureScript/TypeChecker/Monad.hs+1−1

@@ -20,9 +20,9 @@ module Language.PureScript.TypeChecker.Monad where

20

21import Language.PureScript.Types

22import Language.PureScript.Kinds

23−import Language.PureScript.Values

24import Language.PureScript.Names

23import Language.PureScript.Names

25import Language.PureScript.Environment

24import Language.PureScript.Environment

25+import Language.PureScript.TypeClassDictionaries

26

27import Data.Maybe

28

src/Language/PureScript/TypeChecker/Types.hs+74−38

@@ -48,10 +48,11 @@ import Data.Generics

48 something, everywhere, mkQ)

49import Data.Generics.Extras

50

51−import Language.PureScript.Values

51+import Language.PureScript.Declarations

52import Language.PureScript.Types

53import Language.PureScript.Kinds

54import Language.PureScript.Names

55+import Language.PureScript.TypeClassDictionaries

55import Language.PureScript.TypeChecker.Monad

56import Language.PureScript.TypeChecker.Monad

56import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Synonyms

58import Language.PureScript.TypeChecker.Synonyms

@@ -163,48 +164,15 @@ unifyRows r1 r2 =

163typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

164typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

164typesOf mainModuleName moduleName vals = do

165typesOf mainModuleName moduleName vals = do

165 tys <- fmap tidyUp . liftUnify $ do

166 tys <- fmap tidyUp . liftUnify $ do

166− let

167+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

167− -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

168− es = map isTyped vals

169− -- Filter the typed and untyped declarations

170− typed = filter (isJust . snd . snd) es

171− untyped = filter (isNothing . snd . snd) es

172− -- Make a map of names to typed declarations

173− typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed

174− -- Create fresh unification variables for the types of untyped declarations

175− untypedNames <- replicateM (length untyped) fresh

176− let

177− -- Make a map of names to the unification variables of untyped declarations

178− untypedDict = zip (map fst untyped) untypedNames

179− -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

180− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

181− forM es $ \e@(_, (val, _)) -> do

168+ forM es $ \e -> do

182− -- If the declaration is a function, it has access to other values in the binding group.

169+ triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict

183− -- If not, the generated code might fail at runtime since those values might be undefined.

184− let dict' = if isFunction val then dict else M.empty

185− triple@(_, (_, ty)) <- case e of

186− -- Typed declarations

187− (ident, (val', Just (ty, checkType))) -> do

188− -- Kind check

189− kind <- liftCheck $ kindOf moduleName ty

190− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

191− -- Check the type with the new names in scope

192− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

193− val'' <- bindNames dict' $ if checkType

194− then TypedValue True <$> check val' ty' <*> pure ty'

195− else return (TypedValue False val' ty')

196− return (ident, (val'', ty'))

197− -- Untyped declarations

198− (ident, (val', Nothing)) -> do

199− -- Infer the type with the new names in scope

200− TypedValue _ val'' ty <- bindNames dict' $ infer val'

201− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

202− return (ident, (TypedValue True val'' ty, ty))

203 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

170 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

204 when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do

171 when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do

205 [eff, a] <- replicateM 2 fresh

172 [eff, a] <- replicateM 2 fresh

206 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

173 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

207 return triple

174 return triple

175+

208 forM tys $ \(ident, (val, ty)) -> do

176 forM tys $ \(ident, (val, ty)) -> do

209 -- Replace type class dictionary placeholders with actual dictionaries

177 -- Replace type class dictionary placeholders with actual dictionaries

210 val' <- replaceTypeClassDictionaries moduleName val

178 val' <- replaceTypeClassDictionaries moduleName val

@@ -219,6 +187,51 @@ typesOf mainModuleName moduleName vals = do

219 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

187 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

220 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

188 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

221

189

190+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])

191+typeDictionaryForBindingGroup moduleName vals = do

192+ let

193+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

194+ es = map isTyped vals

195+ -- Filter the typed and untyped declarations

196+ typed = filter (isJust . snd . snd) es

197+ untyped = filter (isNothing . snd . snd) es

198+ -- Make a map of names to typed declarations

199+ typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed

200+

201+ -- Create fresh unification variables for the types of untyped declarations

202+ untypedNames <- replicateM (length untyped) fresh

203+

204+ let

205+ -- Make a map of names to the unification variables of untyped declarations

206+ untypedDict = zip (map fst untyped) untypedNames

207+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

208+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

209+ return (es, dict, untypedDict)

210+

211+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))

212+typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do

213+ -- If the declaration is a function, it has access to other values in the binding group.

214+ -- If not, the generated code might fail at runtime since those values might be undefined.

215+ let dict' = if isFunction val then dict else M.empty

216+ case e of

217+ -- Typed declarations

218+ (ident, (val', Just (ty, checkType))) -> do

219+ -- Kind check

220+ kind <- liftCheck $ kindOf moduleName ty

221+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

222+ -- Check the type with the new names in scope

223+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

224+ val'' <- bindNames dict' $ if checkType

225+ then TypedValue True <$> check val' ty' <*> pure ty'

226+ else return (TypedValue False val' ty')

227+ return (ident, (val'', ty'))

228+ -- Untyped declarations

229+ (ident, (val', Nothing)) -> do

230+ -- Infer the type with the new names in scope

231+ TypedValue _ val'' ty <- bindNames dict' $ infer val'

232+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

233+ return (ident, (TypedValue True val'' ty, ty))

234+

222-- |

235-- |

223-- Check if a value introduces a function

236-- Check if a value introduces a function

224--

237--

@@ -547,6 +560,9 @@ infer' (IfThenElse cond th el) = do

547 v3@(TypedValue _ _ t3) <- infer el

560 v3@(TypedValue _ _ t3) <- infer el

548 t2 =?= t3

561 t2 =?= t3

549 return $ TypedValue True (IfThenElse cond' v2 v3) t2

562 return $ TypedValue True (IfThenElse cond' v2 v3) t2

563+infer' (Let ds val) = do

564+ (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

565+ return $ TypedValue True (Let ds' val') valTy

550infer' (TypedValue checkType val ty) = do

566infer' (TypedValue checkType val ty) = do

551 Just moduleName <- checkCurrentModule <$> get

567 Just moduleName <- checkCurrentModule <$> get

552 kind <- liftCheck $ kindOf moduleName ty

568 kind <- liftCheck $ kindOf moduleName ty

@@ -556,6 +572,23 @@ infer' (TypedValue checkType val ty) = do

556 return $ TypedValue True val' ty'

572 return $ TypedValue True val' ty'

557infer' _ = error "Invalid argument to infer"

573infer' _ = error "Invalid argument to infer"

558

574

575+inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

576+inferLetBinding seen [] ret j = (,) seen <$> j ret

577+inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do

578+ valTy <- fresh

579+ Just moduleName <- checkCurrentModule <$> get

580+ TypedValue _ val' valTy' <- bindNames (M.singleton (moduleName, ident) (valTy, nameKind)) $ infer val

581+ valTy =?= valTy'

582+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

583+inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

584+ Just moduleName <- checkCurrentModule <$> get

585+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

586+ ds' <- forM es $ \e -> do

587+ (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict

588+ return $ (ident, LocalVariable, val')

589+ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

590+inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"

591+

559-- |

592-- |

560-- Infer the type of a property inside a record with a given type

593-- Infer the type of a property inside a record with a given type

561--

594--

@@ -784,6 +817,9 @@ check' (Constructor c) ty = do

784 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

817 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

785 _ <- subsumes Nothing repl ty

818 _ <- subsumes Nothing repl ty

786 return $ TypedValue True (Constructor c) ty

819 return $ TypedValue True (Constructor c) ty

820+check' (Let ds val) ty = do

821+ (ds', val') <- inferLetBinding [] ds val (flip check ty)

822+ return $ TypedValue True (Let ds' val') ty

787check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

823check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

788

824

789-- |

825-- |

src/Language/PureScript/TypeClassDictionaries.hsnew file+62

@@ -0,0 +1,62 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.TypeClassDictionaries

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.TypeClassDictionaries where

18+

19+import Data.Data

20+

21+import Language.PureScript.Names

22+import Language.PureScript.Types

23+

24+-- |

25+-- Data representing a type class dictionary which is in scope

26+--

27+data TypeClassDictionaryInScope

28+ = TypeClassDictionaryInScope {

29+ -- |

30+ -- The identifier with which the dictionary can be accessed at runtime

31+ --

32+ tcdName :: Qualified Ident

33+ -- |

34+ -- The name of the type class to which this type class instance applies

35+ --

36+ , tcdClassName :: Qualified ProperName

37+ -- |

38+ -- The types to which this type class instance applies

39+ --

40+ , tcdInstanceTypes :: [Type]

41+ -- |

42+ -- Type class dependencies which must be satisfied to construct this dictionary

43+ --

44+ , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]

45+ -- |

46+ -- The type of this dictionary

47+ --

48+ , tcdType :: TypeClassDictionaryType

49+ } deriving (Show, Data, Typeable)

50+

51+-- |

52+-- The type of a type class dictionary

53+--

54+data TypeClassDictionaryType

55+ -- |

56+ -- A regular type class dictionary

57+ --

58+ = TCDRegular

59+ -- |

60+ -- A type class dictionary which is an alias for an imported dictionary from another module

61+ --

62+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

src/Language/PureScript/Values.hsdeleted−254

@@ -1,254 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Values

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Data types for values, statements, binders and do notation

13−--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

17−

18−module Language.PureScript.Values where

19−

20−import Language.PureScript.Types

21−import Language.PureScript.Names

22−

23−import Data.Data

24−import Data.Generics (mkQ, everything)

25−

26−-- |

27−-- A guard is just a boolean-valued expression that appears alongside a set of binders

28−--

29−type Guard = Value

30−

31−-- |

32−-- Data type for values

33−--

34−data Value

35− -- |

36− -- A numeric literal

37− --

38− = NumericLiteral (Either Integer Double)

39− -- |

40− -- A string literal

41− --

42− | StringLiteral String

43− -- |

44− -- A boolean literal

45− --

46− | BooleanLiteral Bool

47− -- |

48− -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

49− -- will be removed.

50− --

51− | BinaryNoParens (Qualified Ident) Value Value

52− -- |

53− -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

54− -- will be removed.

55− --

56− | Parens Value

57− -- |

58− -- An array literal

59− --

60− | ArrayLiteral [Value]

61− -- |

62− -- An object literal

63− --

64− | ObjectLiteral [(String, Value)]

65− -- |

66− -- An record property accessor expression

67− --

68− | Accessor String Value

69− -- |

70− -- Partial record update

71− --

72− | ObjectUpdate Value [(String, Value)]

73− -- |

74− -- Function introduction

75− --

76− | Abs (Either Ident Binder) Value

77− -- |

78− -- Function application

79− --

80− | App Value Value

81− -- |

82− -- Variable

83− --

84− | Var (Qualified Ident)

85− -- |

86− -- Conditional (if-then-else expression)

87− --

88− | IfThenElse Value Value Value

89− -- |

90− -- A data constructor

91− --

92− | Constructor (Qualified ProperName)

93− -- |

94− -- A case expression. During the case expansion phase of desugaring, top-level binders will get

95− -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

96− --

97− | Case [Value] [CaseAlternative]

98− -- |

99− -- A value with a type annotation

100− --

101− | TypedValue Bool Value Type

102− -- |

103− -- A let binding

104− --

105− | Let (Either Binder (Ident, [Either Ident Binder])) Value Value

106− -- |

107− -- A do-notation block

108− --

109− | Do [DoNotationElement]

110− -- |

111− -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

112− -- placeholders will be replaced with actual expressions representing type classes dictionaries which

113− -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

114− -- instance type, and the type class dictionaries in scope.

115− --

116− | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

117−

118−-- |

119−-- An alternative in a case statement

120−--

121−data CaseAlternative = CaseAlternative

122− { -- |

123− -- A collection of binders with which to match the inputs

124− --

125− caseAlternativeBinders :: [Binder]

126− -- |

127− -- An optional guard

128− --

129− , caseAlternativeGuard :: Maybe Guard

130− -- |

131− -- The result expression

132− --

133− , caseAlternativeResult :: Value

134− } deriving (Show, Data, Typeable)

135−

136−-- |

137−-- Data representing a type class dictionary which is in scope

138−--

139−data TypeClassDictionaryInScope

140− = TypeClassDictionaryInScope {

141− -- |

142− -- The identifier with which the dictionary can be accessed at runtime

143− --

144− tcdName :: Qualified Ident

145− -- |

146− -- The name of the type class to which this type class instance applies

147− --

148− , tcdClassName :: Qualified ProperName

149− -- |

150− -- The types to which this type class instance applies

151− --

152− , tcdInstanceTypes :: [Type]

153− -- |

154− -- Type class dependencies which must be satisfied to construct this dictionary

155− --

156− , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]

157− -- |

158− -- The type of this dictionary

159− --

160− , tcdType :: TypeClassDictionaryType

161− } deriving (Show, Data, Typeable)

162−

163−-- |

164−-- The type of a type class dictionary

165−--

166−data TypeClassDictionaryType

167− -- |

168− -- A regular type class dictionary

169− --

170− = TCDRegular

171− -- |

172− -- A type class dictionary which is an alias for an imported dictionary from another module

173− --

174− | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

175−

176−-- |

177−-- Find the original dictionary which a type class dictionary in scope refers to

178−--

179−canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

180−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

181−canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

182−

183−-- |

184−-- A statement in a do-notation block

185−--

186−data DoNotationElement

187− -- |

188− -- A monadic value without a binder

189− --

190− = DoNotationValue Value

191− -- |

192− -- A monadic value with a binder

193− --

194− | DoNotationBind Binder Value

195− -- |

196− -- A let statement, i.e. a pure value with a binder

197− --

198− | DoNotationLet Binder Value deriving (Show, Data, Typeable)

199−

200−-- |

201−-- Data type for binders

202−--

203−data Binder

204− -- |

205− -- Wildcard binder

206− --

207− = NullBinder

208− -- |

209− -- A binder which matches a boolean literal

210− --

211− | BooleanBinder Bool

212− -- |

213− -- A binder which matches a string literal

214− --

215− | StringBinder String

216− -- |

217− -- A binder which matches a numeric literal

218− --

219− | NumberBinder (Either Integer Double)

220− -- |

221− -- A binder which binds an identifier

222− --

223− | VarBinder Ident

224− -- |

225− -- A binder which matches a data constructor

226− --

227− | ConstructorBinder (Qualified ProperName) [Binder]

228− -- |

229− -- A binder which matches a record and binds its properties

230− --

231− | ObjectBinder [(String, Binder)]

232− -- |

233− -- A binder which matches an array and binds its elements

234− --

235− | ArrayBinder [Binder]

236− -- |

237− -- A binder which matches an array and binds its head and tail

238− --

239− | ConsBinder Binder Binder

240− -- |

241− -- A binder which binds its input to an identifier

242− --

243− | NamedBinder Ident Binder deriving (Show, Data, Typeable)

244−

245−

246−-- |

247−-- Collect all names introduced in binders in an expression

248−--

249−binderNames :: (Data d) => d -> [Ident]

250−binderNames = everything (++) (mkQ [] go)

251− where

252− go (VarBinder ident) = [ident]

253− go (NamedBinder ident _) = [ident]

254− go _ = []