17fedf9 · rowtype-yoga/purescript-native

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

on golang help sign in

User defined operators

17fedf9Phil Freeman13 years ago

PureScript.cabal+7−7

compare with golang

unifiedsplit

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

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

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

13data-dir: ""

14−

14+

15library

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

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

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

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

18 exposed-modules: PureScript

19 exposed: True

20 buildable: True

21 hs-source-dirs: src

22− other-modules: PureScript.TypeChecker.Synonyms

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

23 PureScript.CodeGen.Externs PureScript.CodeGen.JS

24 PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

25 PureScript.CodeGen PureScript.Kinds PureScript.Parser

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

28 PureScript.Parser.Types PureScript.Parser.Values

29 PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

30 PureScript.TypeChecker.Types

31−

31+

32executable psc

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

34 mtl -any, parsec -any, utf8-string -any

35 main-is: Main.hs

36 buildable: True

37 hs-source-dirs: src

38− other-modules: PureScript.TypeChecker.Synonyms

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

39 PureScript.CodeGen.Externs PureScript.CodeGen.JS

40 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)

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

5test3 = (\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

26import PureScript.Values

27import PureScript.Types

28+import PureScript.Names

28import PureScript.Declarations

29import PureScript.Declarations

29import PureScript.TypeChecker.Monad

30import PureScript.TypeChecker.Monad

30import PureScript.CodeGen.Common

31import PureScript.CodeGen.Common

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

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

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

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

35typeLiterals :: Pattern Type String

36typeLiterals :: Pattern Type String

36typeLiterals = Pattern $ A.Kleisli match

37typeLiterals = Pattern $ A.Kleisli match

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

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

16 declToJs

17) where

19+import Data.Char

19import Data.Maybe (fromMaybe)

20import Data.Maybe (fromMaybe)

20import Data.List (intercalate)

21import Data.List (intercalate)

21import qualified Control.Arrow as A

22import qualified Control.Arrow as A

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

24import PureScript.Types

25import PureScript.Types

25import PureScript.Values

26import PureScript.Values

27+import PureScript.Names

26import PureScript.Declarations

28import PureScript.Declarations

27import PureScript.CodeGen.Common

29import PureScript.CodeGen.Common

28import PureScript.CodeGen.Common.Gen

30import PureScript.CodeGen.Common.Gen

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+

30declToJs :: Declaration -> Maybe String

39declToJs :: Declaration -> Maybe String

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

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

32declToJs (DataDeclaration _ _ ctors) =

41declToJs (DataDeclaration _ _ ctors) =

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

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

34 case maybeTy of

43 case maybeTy of

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

56 let js = valueToJs result

65 let js = valueToJs result

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

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

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

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

59− match (Var ident) = Just ident

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

60 match _ = Nothing

69 match _ = Nothing

62accessor :: Pattern Value (String, Value)

71accessor :: Pattern Value (String, Value)

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

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

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

81lam = Pattern $ A.Kleisli match

90lam = Pattern $ A.Kleisli match

82 where

91 where

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

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

84 match _ = Nothing

93 match _ = Nothing

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

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

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

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

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

174binderToJs varName done (BooleanBinder False) =

183binderToJs varName done (BooleanBinder False) =

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

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

176−binderToJs varName done (VarBinder s) =

185+binderToJs varName done (VarBinder ident) =

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

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

178binderToJs varName done (NullaryBinder ctor) =

187binderToJs varName done (NullaryBinder ctor) =

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

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

180binderToJs varName done (UnaryBinder ctor b) = do

189binderToJs varName done (UnaryBinder ctor b) = do

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

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

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

210

219

211statementToJs :: Statement -> String

220statementToJs :: Statement -> String

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

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

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

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

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

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

215 ++ valueToJs cond ++ ") {"

224 ++ valueToJs cond ++ ") {"

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

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

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

228

237

229assignmentTargetToJs :: AssignmentTarget -> String

238assignmentTargetToJs :: AssignmentTarget -> String

230−assignmentTargetToJs (AssignVariable var) = var

239+assignmentTargetToJs (AssignVariable ident) = identToJs ident

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

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

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

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

src/PureScript/Declarations.hs+4−3

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

19import PureScript.Values

20import PureScript.Types

21+import PureScript.Names

22import Data.Data

23import Data.Data

24data Declaration

25data Declaration

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

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

26 | TypeSynonymDeclaration String [String] Type

27 | TypeSynonymDeclaration String [String] Type

27− | TypeDeclaration String PolyType

28+ | TypeDeclaration Ident PolyType

28− | ValueDeclaration String Value

29+ | ValueDeclaration Ident Value

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

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

19import qualified Text.Parsec.Token as PT

20import qualified Text.Parsec.Language as PL

22+import PureScript.Names

23+

22langDef = PL.haskellStyle

24langDef = PL.haskellStyle

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

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

24 , PT.reservedNames = [ "case"

26 , PT.reservedNames = [ "case"

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

35 , "false"

37 , "false"

36 , "extern"

38 , "extern"

37 , "forall" ]

39 , "forall" ]

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

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

38 }

42 }

40tokenParser = PT.makeTokenParser langDef

44tokenParser = PT.makeTokenParser langDef

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

60commaSep = PT.commaSep tokenParser

64commaSep = PT.commaSep tokenParser

61commaSep1 = PT.commaSep1 tokenParser

65commaSep1 = PT.commaSep1 tokenParser

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

68+

63properName :: P.Parsec String u String

69properName :: P.Parsec String u String

64properName = lexeme $ P.try properName'

70properName = lexeme $ P.try properName'

65 where

71 where

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

73 a <- first

79 a <- first

74 bs <- P.many more

80 bs <- P.many more

75 return $ foldl combine a bs

81 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

42 return $ DataDeclaration name tyArgs ctors

44parseTypeDeclaration :: P.Parsec String () Declaration

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

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

47parseTypeSynonymDeclaration :: P.Parsec String () Declaration

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

50parseValueDeclaration :: P.Parsec String () Declaration

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

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

53parseExternDeclaration :: 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)

56parseDeclaration :: P.Parsec String () Declaration

57parseDeclaration = P.choice $ map P.try

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

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

55parseAbs :: P.Parsec String () Value

56parseAbs = do

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

58− args <- C.commaSep C.identifier

58+ args <- C.commaSep C.parseIdent

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

60 value <- parseValue

61 return $ Abs args value

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

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

67parseVar :: P.Parsec String () Value

68−parseVar = Var <$> C.identifier

68+parseVar = Var <$> C.parseIdent

70parseConstructor :: P.Parsec String () Value

71parseConstructor = Constructor <$> C.properName

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

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

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

107 , 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 ]

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

109 , [ 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.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 LessThan)) AssocRight

111− , [ Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) 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

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

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

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

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

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

116 , [ 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

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

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

130parseVariableIntroduction requireSemi = do

132parseVariableIntroduction requireSemi = do

131 C.reserved "var"

133 C.reserved "var"

132− name <- C.identifier

134+ name <- C.parseIdent

133 C.lexeme $ P.char '='

135 C.lexeme $ P.char '='

134 value <- parseValue

136 value <- parseValue

135 when requireSemi (void C.semi)

137 when requireSemi (void C.semi)

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

186parseNumberBinder = NumberBinder <$> C.naturalOrFloat

188parseNumberBinder = NumberBinder <$> C.naturalOrFloat

187

189

188parseVarBinder :: P.Parsec String () Binder

190parseVarBinder :: P.Parsec String () Binder

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

191+parseVarBinder = VarBinder <$> C.parseIdent

190

192

191parseNullaryBinder :: P.Parsec String () Binder

193parseNullaryBinder :: P.Parsec String () Binder

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

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

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

220 , C.parens parseBinder ]

222 , C.parens parseBinder ]

221

223

222parseAssignmentTarget :: P.Parsec String () AssignmentTarget

224parseAssignmentTarget :: P.Parsec String () AssignmentTarget

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

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

224 where

226 where

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

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

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

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

src/PureScript/TypeChecker.hs+6−6

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

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

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

53 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

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

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

57 let polyType = PolyType args dctorTy

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

67 typeCheckAll rest

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

69 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

71typeCheckAll (ValueDeclaration name val : rest) = do

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

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

73 env <- getEnv

74 case M.lookup name (names env) of

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

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

76 Nothing -> do

77 ty <- typeOf name val

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

79 typeCheckAll rest

80typeCheckAll (ExternDeclaration name ty : rest) = do

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

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

82 env <- getEnv

83 kind <- kindOf ty

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

85 case M.lookup name (names env) of

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

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

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

88 typeCheckAll rest

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

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

19import PureScript.Types

20import PureScript.Kinds

21+import PureScript.Names

22import Control.Applicative

23import Control.Applicative

23import Control.Monad.State

24import Control.Monad.State

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

32data TypeDeclarationKind = Data | TypeSynonym deriving Show

33data TypeDeclarationKind = Data | TypeSynonym deriving Show

34data Environment = Environment

35data Environment = Environment

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

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

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

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

37 , dataConstructors :: M.Map String PolyType

38 , dataConstructors :: M.Map String PolyType

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

39 , 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,

26import PureScript.Values

27import PureScript.Types

28import PureScript.Kinds

29+import PureScript.Names

29import PureScript.TypeChecker.Monad

30import PureScript.TypeChecker.Monad

30import PureScript.TypeChecker.Kinds

31import PureScript.TypeChecker.Kinds

31import PureScript.TypeChecker.Synonyms

32import PureScript.TypeChecker.Synonyms

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

48emptyTypeSolution :: TypeSolution

49emptyTypeSolution :: TypeSolution

49emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

50emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

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

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

52typeOf name val = do

53typeOf name val = do

53 me <- fresh

54 me <- fresh

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

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

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

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

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

137 g _ = False

138 g _ = False

138

139

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

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

140typeConstraints _ (NumericLiteral _) = do

141typeConstraints _ (NumericLiteral _) = do

141 me <- fresh

142 me <- fresh

142 return ([TypeConstraint me Number], me)

143 return ([TypeConstraint me Number], me)

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

196 Nothing -> do

197 Nothing -> do

197 env <- getEnv

198 env <- getEnv

198 case M.lookup var (names env) of

199 case M.lookup var (names env) of

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

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

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

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

201 me <- fresh

202 me <- fresh

202 replaced <- replaceVarsWithUnknowns idents ty

203 replaced <- replaceVarsWithUnknowns idents ty

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

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

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

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

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

277

278

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

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

279typeConstraintsForBinder val (StringBinder _) = constantBinder val String

280typeConstraintsForBinder val (StringBinder _) = constantBinder val String

280typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

281typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

281typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

282typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

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

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

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

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

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

307 where

308 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)

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

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

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

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

311 propTy <- fresh

312 propTy <- fresh

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

323 (cs2, m2) <- typeConstraintsForBinder val binder

324 (cs2, m2) <- typeConstraintsForBinder val binder

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

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

325

326

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

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

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

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

328

329

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

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

330typeConstraintsForBinders _ _ _ [] = return []

331typeConstraintsForBinders _ _ _ [] = return []

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

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

332 (cs1, m1) <- typeConstraintsForBinder nval binder

333 (cs1, m1) <- typeConstraintsForBinder nval binder

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

334 cs3 <- typeConstraintsForBinders m nval ret bs

335 cs3 <- typeConstraintsForBinders m nval ret bs

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

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

336

337

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)

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

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

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

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

340 Nothing -> do

341 Nothing -> do

341 (cs1, n1) <- typeConstraints m val

342 (cs1, n1) <- typeConstraints m val

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

343 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."

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

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

345 (cs1, n1) <- typeConstraints m val

346 (cs1, n1) <- typeConstraints m val

346 cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

347 cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

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

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

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

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

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

372

373

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]

374typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =

375typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =

375 case M.lookup var mass of

376 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

377 Just ty -> do

378 Just ty -> do

378 return [TypeConstraint nval (TUnknown ty)]

379 return [TypeConstraint nval (TUnknown ty)]

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

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

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

387 cs <- typeConstraintsForAssignmentTarget m mass obj tgt

388 cs <- typeConstraintsForAssignmentTarget m mass obj tgt

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

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

389

390

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)

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

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

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

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

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

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

src/PureScript/Values.hs+6−5

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

17module PureScript.Values where

19import PureScript.Types

20+import PureScript.Names

21import Data.Data

22import Data.Data

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

57 | Indexer Value Value

58 | Indexer Value Value

58 | ObjectLiteral [(String, Value)]

59 | ObjectLiteral [(String, Value)]

59 | Accessor String Value

60 | Accessor String Value

60− | Abs [String] Value

61+ | Abs [Ident] Value

61 | App Value [Value]

62 | App Value [Value]

62− | Var String

63+ | Var Ident

63 | Block [Statement]

64 | Block [Statement]

64 | Constructor String

65 | Constructor String

65 | Case Value [(Binder, Value)]

66 | Case Value [(Binder, Value)]

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

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

68data Statement

69data Statement

69− = VariableIntroduction String Value

70+ = VariableIntroduction Ident Value

70 | Assignment AssignmentTarget Value

71 | Assignment AssignmentTarget Value

71 | While Value [Statement]

72 | While Value [Statement]

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

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

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

77 = BooleanBinder Bool

78 = BooleanBinder Bool

78 | StringBinder String

79 | StringBinder String

79 | NumberBinder (Either Integer Double)

80 | NumberBinder (Either Integer Double)

80− | VarBinder String

81+ | VarBinder Ident

81 | NullaryBinder String

82 | NullaryBinder String

82 | UnaryBinder String Binder

83 | UnaryBinder String Binder

83 | ObjectBinder [(String, Binder)]

84 | ObjectBinder [(String, Binder)]

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

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

86data AssignmentTarget

87data AssignmentTarget

87− = AssignVariable String

88+ = AssignVariable Ident

88 | AssignObjectProperty String AssignmentTarget

89 | AssignObjectProperty String AssignmentTarget

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

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