17fedf9 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

User defined operators

commit17fedf92691f86c499e43bc7a5b0963acf6aa5e0 authorPhil Freeman <paf31@cantab.net> dateWed 9 Oct 2013, 18:15 (13 years ago) parent5d428e9

13 files changed+118−54

compare with golang

unifiedsplit

PureScript.cabal+7−7 examples/Operators.ps+10 src/PureScript/CodeGen/Externs.hs+3−2 src/PureScript/CodeGen/JS.hs+16−7 src/PureScript/Declarations.hs+4−3 src/PureScript/Names.hs+26 src/PureScript/Parser/Common.hs+12 src/PureScript/Parser/Declarations.hs+3−3 src/PureScript/Parser/Values.hs+10−8 src/PureScript/TypeChecker.hs+6−6 src/PureScript/TypeChecker/Monad.hs+2−1 src/PureScript/TypeChecker/Types.hs+13−12 src/PureScript/Values.hs+6−5

PureScript.cabal+7−7

@@ -11,15 +11,15 @@ synopsis: PureScript Programming Language Compiler

1111description: A small compile-to-JS language with extensible records and type-safe blocks

1212author: Phil Freeman <paf31@cantab.net>

1313data-dir: ""

14−

14+

1515library

16− build-depends: base -any, syb -any, cmdtheline -any, containers -any,

17− mtl -any, parsec -any, utf8-string -any

16+ build-depends: base -any, syb -any, cmdtheline -any,

17+ containers -any, mtl -any, parsec -any, utf8-string -any

1818 exposed-modules: PureScript

1919 exposed: True

2020 buildable: True

2121 hs-source-dirs: src

22− other-modules: PureScript.TypeChecker.Synonyms

22+ other-modules: PureScript.Names PureScript.TypeChecker.Synonyms

2323 PureScript.CodeGen.Externs PureScript.CodeGen.JS

2424 PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

2525 PureScript.CodeGen PureScript.Kinds PureScript.Parser

@@ -28,14 +28,14 @@ library

2828 PureScript.Parser.Types PureScript.Parser.Values

2929 PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

3030 PureScript.TypeChecker.Types

31−

31+

3232executable psc

3333 build-depends: base -any, cmdtheline -any, containers -any,

3434 mtl -any, parsec -any, utf8-string -any

3535 main-is: Main.hs

3636 buildable: True

3737 hs-source-dirs: src

38− other-modules: PureScript.TypeChecker.Synonyms

38+ other-modules: PureScript.Names PureScript.TypeChecker.Synonyms

3939 PureScript.CodeGen.Externs PureScript.CodeGen.JS

4040 PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common

41−

41+

examples/Operators.ps+10

@@ -3,3 +3,13 @@ test1 = \x, y, z -> x * y + z(x)(y)

33test2 = (\x -> (x.foo)(false))({ foo : \_ -> 1 })

55test3 = (\x, y -> x)(1 + 2 * (1 + 2), true && (false || false))

7+k = \x -> \y -> x

9+test4 = 1 `k` 2

10+

11+(%%) = \x -> \y -> x * y + y

12+

13+test5 = 1 %% 2 %% 3

14+

15+test6 = ((\x -> x) `k` 2) (3)

src/PureScript/CodeGen/Externs.hs+3−2

@@ -25,12 +25,13 @@ import Control.Applicative

2525

2626import PureScript.Values

2727import PureScript.Types

28+import PureScript.Names

2829import PureScript.Declarations

2930import PureScript.TypeChecker.Monad

3031import PureScript.CodeGen.Common

3132

32−externToPs :: String -> (PolyType, NameKind) -> String

33−externToPs name (ty, _) = "extern " ++ name ++ " :: " ++ polyTypeToPs ty

33+externToPs :: Ident -> (PolyType, NameKind) -> String

34+externToPs name (ty, _) = "extern " ++ show name ++ " :: " ++ polyTypeToPs ty

3435

3536typeLiterals :: Pattern Type String

3637typeLiterals = Pattern $ A.Kleisli match

src/PureScript/CodeGen/JS.hs+16−7

@@ -16,6 +16,7 @@ module PureScript.CodeGen.JS (

1616 declToJs

1717) where

1818

19+import Data.Char

1920import Data.Maybe (fromMaybe)

2021import Data.List (intercalate)

2122import qualified Control.Arrow as A

@@ -23,12 +24,20 @@ import Control.Applicative

2324

2425import PureScript.Types

2526import PureScript.Values

27+import PureScript.Names

2628import PureScript.Declarations

2729import PureScript.CodeGen.Common

2830import PureScript.CodeGen.Common.Gen

2931

32+identToJs :: Ident -> String

33+identToJs (Ident name) = name

34+identToJs (Op op) = concatMap opCharToString op

35+ where

36+ opCharToString :: Char -> String

37+ opCharToString = (:) '$'. show . ord

38+

3039declToJs :: Declaration -> Maybe String

31−declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"

40+declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"

3241declToJs (DataDeclaration _ _ ctors) =

3342 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->

3443 case maybeTy of

@@ -56,7 +65,7 @@ literals = Pattern $ A.Kleisli match

5665 let js = valueToJs result

5766 binderToJs valName ("return " ++ js ++ ";") binder

5867 return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"

59− match (Var ident) = Just ident

68+ match (Var ident) = Just (identToJs ident)

6069 match _ = Nothing

6170

6271accessor :: Pattern Value (String, Value)

@@ -80,7 +89,7 @@ app = Pattern $ A.Kleisli match

8089lam :: Pattern Value ([String], Value)

8190lam = Pattern $ A.Kleisli match

8291 where

83− match (Abs args val) = Just (args, val)

92+ match (Abs args val) = Just (map identToJs args, val)

8493 match _ = Nothing

8594

8695unary :: UnaryOperator -> String -> Operator Value String

@@ -173,8 +182,8 @@ binderToJs varName done (BooleanBinder True) =

173182 return $ "if (" ++ varName ++ ") {" ++ done ++ " }"

174183binderToJs varName done (BooleanBinder False) =

175184 return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"

176−binderToJs varName done (VarBinder s) =

177− return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done

185+binderToJs varName done (VarBinder ident) =

186+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done

178187binderToJs varName done (NullaryBinder ctor) =

179188 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"

180189binderToJs varName done (UnaryBinder ctor b) = do

@@ -209,7 +218,7 @@ objectPropertyToJs :: (String, Value) -> String

209218objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

210219

211220statementToJs :: Statement -> String

212−statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value

221+statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value

213222statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value

214223statementToJs (While cond sts) = "while ("

215224 ++ valueToJs cond ++ ") {"

@@ -227,6 +236,6 @@ statementToJs (IfThenElse cond thens elses) = "if ("

227236statementToJs (Return value) = "return " ++ valueToJs value

228237

229238assignmentTargetToJs :: AssignmentTarget -> String

230−assignmentTargetToJs (AssignVariable var) = var

239+assignmentTargetToJs (AssignVariable ident) = identToJs ident

231240assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"

232241assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop

src/PureScript/Declarations.hs+4−3

@@ -18,12 +18,13 @@ module PureScript.Declarations where

1818

1919import PureScript.Values

2020import PureScript.Types

21+import PureScript.Names

2122

2223import Data.Data

2324

2425data Declaration

2526 = DataDeclaration String [String] [(String, Maybe Type)]

2627 | TypeSynonymDeclaration String [String] Type

27− | TypeDeclaration String PolyType

28− | ValueDeclaration String Value

29− | ExternDeclaration String PolyType deriving (Show, Data, Typeable)

28+ | TypeDeclaration Ident PolyType

29+ | ValueDeclaration Ident Value

30+ | ExternDeclaration Ident PolyType deriving (Show, Data, Typeable)

src/PureScript/Names.hsnew file+26

@@ -0,0 +1,26 @@

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

2+--

3+-- Module : PureScript.Names

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+--

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

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Names where

18+

19+import Data.Data

20+

21+data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

22+

23+instance Show Ident where

24+ show (Ident s) = s

25+ show (Op op) = '(':op ++ ")"

26+

src/PureScript/Parser/Common.hs+12

@@ -19,6 +19,8 @@ import qualified Text.Parsec as P

1919import qualified Text.Parsec.Token as PT

2020import qualified Text.Parsec.Language as PL

2121

22+import PureScript.Names

23+

2224langDef = PL.haskellStyle

2325 { PT.identStart = P.lower <|> P.char '_'

2426 , PT.reservedNames = [ "case"

@@ -35,6 +37,8 @@ langDef = PL.haskellStyle

3537 , "false"

3638 , "extern"

3739 , "forall" ]

40+ , PT.reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

41+ , "==", "!=", "&", "^", "|", "&&", "||" ]

3842 }

3943

4044tokenParser = PT.makeTokenParser langDef

@@ -60,6 +64,8 @@ semiSep1 = PT.semiSep1 tokenParser

6064commaSep = PT.commaSep tokenParser

6165commaSep1 = PT.commaSep1 tokenParser

6266

67+tick = lexeme (P.char '`')

68+

6369properName :: P.Parsec String u String

6470properName = lexeme $ P.try properName'

6571 where

@@ -73,3 +79,9 @@ fold first more combine = do

7379 a <- first

7480 bs <- P.many more

7581 return $ foldl combine a bs

82+

83+parseIdent :: P.Parsec String () Ident

84+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)

85+

86+parseIdentInfix :: P.Parsec String () Ident

87+parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)

src/PureScript/Parser/Declarations.hs+3−3

@@ -42,16 +42,16 @@ parseDataDeclaration = do

4242 return $ DataDeclaration name tyArgs ctors

4343

4444parseTypeDeclaration :: P.Parsec String () Declaration

45−parseTypeDeclaration = TypeDeclaration <$> identifier <*> (lexeme (P.string "::") *> parsePolyType)

45+parseTypeDeclaration = TypeDeclaration <$> parseIdent <*> (lexeme (P.string "::") *> parsePolyType)

4646

4747parseTypeSynonymDeclaration :: P.Parsec String () Declaration

4848parseTypeSynonymDeclaration = TypeSynonymDeclaration <$> (reserved "type" *> properName) <*> many identifier <*> (lexeme (P.char '=') *> parseType)

4949

5050parseValueDeclaration :: P.Parsec String () Declaration

51−parseValueDeclaration = ValueDeclaration <$> identifier <*> (lexeme (P.char '=') *> parseValue)

51+parseValueDeclaration = ValueDeclaration <$> parseIdent <*> (lexeme (P.char '=') *> parseValue)

5252

5353parseExternDeclaration :: P.Parsec String () Declaration

54−parseExternDeclaration = ExternDeclaration <$> (reserved "extern" *> (identifier <|> properName)) <*> (lexeme (P.string "::") *> parsePolyType)

54+parseExternDeclaration = ExternDeclaration <$> (reserved "extern" *> parseIdent) <*> (lexeme (P.string "::") *> parsePolyType)

5555

5656parseDeclaration :: P.Parsec String () Declaration

5757parseDeclaration = P.choice $ map P.try

src/PureScript/Parser/Values.hs+10−8

@@ -55,7 +55,7 @@ parseIdentifierAndValue = do

5555parseAbs :: P.Parsec String () Value

5656parseAbs = do

5757 C.lexeme $ P.char '\\'

58− args <- C.commaSep C.identifier

58+ args <- C.commaSep C.parseIdent

5959 C.lexeme $ P.string "->"

6060 value <- parseValue

6161 return $ Abs args value

@@ -65,7 +65,7 @@ parseApp = App <$> parseValue

6565 <*> (C.parens $ C.commaSep parseValue)

6666

6767parseVar :: P.Parsec String () Value

68−parseVar = Var <$> C.identifier

68+parseVar = Var <$> C.parseIdent

6969

7070parseConstructor :: P.Parsec String () Value

7171parseConstructor = Constructor <$> C.properName

@@ -105,10 +105,12 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

105105 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)

106106 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)

107107 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]

108+ , [ Infix (C.lexeme (C.parseIdentInfix >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]

108109 , [ Infix (C.lexeme (P.try (P.string "<=")) >> return (Binary LessThanOrEqualTo)) AssocRight

109− , Infix (C.lexeme (P.try (P.string ">=")) >> return (Binary GreaterThanOrEqualTo)) AssocRight

110− , Infix (C.lexeme (P.try (P.char '<' <* P.notFollowedBy (P.char '<'))) >> return (Binary LessThan)) AssocRight ]

111− , [ Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) AssocRight

110+ , Infix (C.lexeme (P.try (P.string ">=")) >> return (Binary GreaterThanOrEqualTo)) AssocRight ]

111+ , [ Infix (C.lexeme (P.try (P.char '<' <* P.notFollowedBy (P.char '<'))) >> return (Binary LessThan)) AssocRight

112+ , Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) AssocRight ]

113+ , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight

112114 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight

113115 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]

114116 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight

@@ -129,7 +131,7 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

129131parseVariableIntroduction :: Bool -> P.Parsec String () Statement

130132parseVariableIntroduction requireSemi = do

131133 C.reserved "var"

132− name <- C.identifier

134+ name <- C.parseIdent

133135 C.lexeme $ P.char '='

134136 value <- parseValue

135137 when requireSemi (void C.semi)

@@ -186,7 +188,7 @@ parseNumberBinder :: P.Parsec String () Binder

186188parseNumberBinder = NumberBinder <$> C.naturalOrFloat

187189

188190parseVarBinder :: P.Parsec String () Binder

189−parseVarBinder = VarBinder <$> C.lexeme C.identifier

191+parseVarBinder = VarBinder <$> C.parseIdent

190192

191193parseNullaryBinder :: P.Parsec String () Binder

192194parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName

@@ -220,7 +222,7 @@ parseBinder = P.choice $ map P.try

220222 , C.parens parseBinder ]

221223

222224parseAssignmentTarget :: P.Parsec String () AssignmentTarget

223−parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.identifier)

225+parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)

224226 where

225227 operators = [ [ Postfix $ AssignArrayIndex <$> C.squares parseValue

226228 , Postfix $ AssignObjectProperty <$> (C.dot *> C.identifier) ] ]

src/PureScript/TypeChecker.hs+6−6

@@ -51,7 +51,7 @@ typeCheckAll (DataDeclaration name args dctors : rest) = do

5151 flip mapM_ dctors $ \(dctor, maybeTy) ->

5252 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

5353 env' <- getEnv

54− guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor

54+ guardWith (dctor ++ " is already defined") $ not $ flip M.member (dataConstructors env') dctor

5555 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)

5656 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

5757 let polyType = PolyType args dctorTy

@@ -67,22 +67,22 @@ typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

6767 typeCheckAll rest

6868typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =

6969 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)

70−typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ name

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

7171typeCheckAll (ValueDeclaration name val : rest) = do

72− rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do

72+ rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do

7373 env <- getEnv

7474 case M.lookup name (names env) of

75− Just ty -> throwError $ name ++ " is already defined"

75+ Just ty -> throwError $ show name ++ " is already defined"

7676 Nothing -> do

7777 ty <- typeOf name val

7878 putEnv (env { names = M.insert name (ty, Value) (names env) })

7979 typeCheckAll rest

8080typeCheckAll (ExternDeclaration name ty : rest) = do

81− rethrow (("Error in extern declaration " ++ name ++ ": ") ++) $ do

81+ rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do

8282 env <- getEnv

8383 kind <- kindOf ty

8484 guardWith "Expected kind *" $ kind == Star

8585 case M.lookup name (names env) of

86− Just _ -> throwError $ name ++ " is already defined"

86+ Just _ -> throwError $ show name ++ " is already defined"

8787 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })

8888 typeCheckAll rest

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

@@ -18,6 +18,7 @@ module PureScript.TypeChecker.Monad where

1818

1919import PureScript.Types

2020import PureScript.Kinds

21+import PureScript.Names

2122

2223import Control.Applicative

2324import Control.Monad.State

@@ -32,7 +33,7 @@ data NameKind = Value | Extern deriving Show

3233data TypeDeclarationKind = Data | TypeSynonym deriving Show

3334

3435data Environment = Environment

35− { names :: M.Map String (PolyType, NameKind)

36+ { names :: M.Map Ident (PolyType, NameKind)

3637 , types :: M.Map String (Kind, TypeDeclarationKind)

3738 , dataConstructors :: M.Map String PolyType

3839 , typeSynonyms :: M.Map String ([String], Type)

src/PureScript/TypeChecker/Types.hs+13−12

@@ -26,6 +26,7 @@ import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM,

2626import PureScript.Values

2727import PureScript.Types

2828import PureScript.Kinds

29+import PureScript.Names

2930import PureScript.TypeChecker.Monad

3031import PureScript.TypeChecker.Kinds

3132import PureScript.TypeChecker.Synonyms

@@ -48,7 +49,7 @@ newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Ro

4849emptyTypeSolution :: TypeSolution

4950emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

5051

51−typeOf :: String -> Value -> Check PolyType

52+typeOf :: Ident -> Value -> Check PolyType

5253typeOf name val = do

5354 me <- fresh

5455 (cs, n) <- typeConstraints (M.singleton name me) val

@@ -136,7 +137,7 @@ occursCheck u = everything (||) $ flip extQ g $ mkQ False f

136137 g (RUnknown u') | u' == u = True

137138 g _ = False

138139

139−typeConstraints :: M.Map String Int -> Value -> Check ([TypeConstraint], Int)

140+typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

140141typeConstraints _ (NumericLiteral _) = do

141142 me <- fresh

142143 return ([TypeConstraint me Number], me)

@@ -196,7 +197,7 @@ typeConstraints m (Var var) =

196197 Nothing -> do

197198 env <- getEnv

198199 case M.lookup var (names env) of

199− Nothing -> throwError $ var ++ " is undefined"

200+ Nothing -> throwError $ show var ++ " is undefined"

200201 Just (PolyType idents ty, _) -> do

201202 me <- fresh

202203 replaced <- replaceVarsWithUnknowns idents ty

@@ -275,7 +276,7 @@ symBinOpConstraints ty left right result = asymBinOpConstraints ty ty left right

275276asymBinOpConstraints :: Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

276277asymBinOpConstraints ty res left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result res]

277278

278−typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map String Int)

279+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)

279280typeConstraintsForBinder val (StringBinder _) = constantBinder val String

280281typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

281282typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

@@ -305,7 +306,7 @@ typeConstraintsForBinder val (ObjectBinder props) = do

305306 (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props

306307 return ((TypeConstraint val (Object (RUnknown row))) : cs, m1)

307308 where

308− typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map String Int)

309+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)

309310 typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row], M.empty)

310311 typeConstraintsForProperties nrow row ((name, binder):binders) = do

311312 propTy <- fresh

@@ -323,10 +324,10 @@ typeConstraintsForBinder val (ArrayBinder binders rest) = do

323324 (cs2, m2) <- typeConstraintsForBinder val binder

324325 return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)

325326

326−constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map String Int)

327+constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)

327328constantBinder val ty = return ([TypeConstraint val ty], M.empty)

328329

329−typeConstraintsForBinders :: M.Map String Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

330+typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

330331typeConstraintsForBinders _ _ _ [] = return []

331332typeConstraintsForBinders m nval ret ((binder, val):bs) = do

332333 (cs1, m1) <- typeConstraintsForBinder nval binder

@@ -334,13 +335,13 @@ typeConstraintsForBinders m nval ret ((binder, val):bs) = do

334335 cs3 <- typeConstraintsForBinders m nval ret bs

335336 return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3)

336337

337−typeConstraintsForStatement :: M.Map String Int -> M.Map String Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map String Int)

338+typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map Ident Int)

338339typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do

339340 case M.lookup name (m `M.union` mass) of

340341 Nothing -> do

341342 (cs1, n1) <- typeConstraints m val

342343 return $ (cs1, False, M.insert name n1 mass)

343− Just ty -> throwError $ "Variable with name " ++ name ++ " already exists."

344+ Just ty -> throwError $ "Variable with name " ++ show name ++ " already exists."

344345typeConstraintsForStatement m mass ret (Assignment tgt val) = do

345346 (cs1, n1) <- typeConstraints m val

346347 cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

@@ -370,10 +371,10 @@ typeConstraintsForStatement m mass ret (Return val) = do

370371 (cs1, n1) <- typeConstraints (m `M.union` mass) val

371372 return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)

372373

373−typeConstraintsForAssignmentTarget :: M.Map String Int -> M.Map String Int -> Int -> AssignmentTarget -> Check [TypeConstraint]

374+typeConstraintsForAssignmentTarget :: M.Map Ident Int -> M.Map Ident Int -> Int -> AssignmentTarget -> Check [TypeConstraint]

374375typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =

375376 case M.lookup var mass of

376− Nothing -> throwError $ "No local variable with name " ++ var

377+ Nothing -> throwError $ "No local variable with name " ++ show var

377378 Just ty -> do

378379 return [TypeConstraint nval (TUnknown ty)]

379380typeConstraintsForAssignmentTarget m mass nval (AssignArrayIndex index tgt) = do

@@ -387,7 +388,7 @@ typeConstraintsForAssignmentTarget m mass nval (AssignObjectProperty prop tgt) =

387388 cs <- typeConstraintsForAssignmentTarget m mass obj tgt

388389 return $ (TypeConstraint obj (Object (RCons prop (TUnknown nval) $ RUnknown row))) : cs

389390

390−typeConstraintsForBlock :: M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map String Int)

391+typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)

391392typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

392393typeConstraintsForBlock m mass ret (s:ss) = do

393394 (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s

src/PureScript/Values.hs+6−5

@@ -17,6 +17,7 @@

1717module PureScript.Values where

1818

1919import PureScript.Types

20+import PureScript.Names

2021

2122import Data.Data

2223

@@ -57,16 +58,16 @@ data Value

5758 | Indexer Value Value

5859 | ObjectLiteral [(String, Value)]

5960 | Accessor String Value

60− | Abs [String] Value

61+ | Abs [Ident] Value

6162 | App Value [Value]

62− | Var String

63+ | Var Ident

6364 | Block [Statement]

6465 | Constructor String

6566 | Case Value [(Binder, Value)]

6667 | TypedValue Value PolyType deriving (Show, Data, Typeable)

6768

6869data Statement

69− = VariableIntroduction String Value

70+ = VariableIntroduction Ident Value

7071 | Assignment AssignmentTarget Value

7172 | While Value [Statement]

7273 | For (Statement, Value, Statement) [Statement]

@@ -77,13 +78,13 @@ data Binder

7778 = BooleanBinder Bool

7879 | StringBinder String

7980 | NumberBinder (Either Integer Double)

80− | VarBinder String

81+ | VarBinder Ident

8182 | NullaryBinder String

8283 | UnaryBinder String Binder

8384 | ObjectBinder [(String, Binder)]

8485 | ArrayBinder [Binder] (Maybe Binder) deriving (Show, Data, Typeable)

8586

8687data AssignmentTarget

87− = AssignVariable String

88+ = AssignVariable Ident

8889 | AssignObjectProperty String AssignmentTarget

8990 | AssignArrayIndex Value AssignmentTarget deriving (Show, Data, Typeable)