git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fixity declarations
a9905bfPhil Freeman
PureScript.cabal+10−8
compare with golang
unifiedsplit
@@ -13,9 +13,11 @@ author: Phil Freeman <paf31@cantab.net>
13data-dir: ""
13data-dir: ""
14
14
15library
15library
16− build-depends: base -any, syb -any, cmdtheline -any,
16+ build-depends: base -any, syb -any,
17− containers -any, mtl -any, parsec -any, utf8-string -any
17+ cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
18+ utf8-string -any
18− exposed-modules: PureScript PureScript.Declarations PureScript.Names PureScript.TypeChecker.Synonyms
19+ exposed-modules: PureScript PureScript.Declarations
20+ PureScript.Names PureScript.TypeChecker.Synonyms
19 PureScript.CodeGen.Externs PureScript.CodeGen.JS
21 PureScript.CodeGen.Externs PureScript.CodeGen.JS
20 PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
22 PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
21 PureScript.CodeGen PureScript.Kinds PureScript.Parser
23 PureScript.CodeGen PureScript.Kinds PureScript.Parser
@@ -23,16 +25,16 @@ library
23 PureScript.Parser.Common PureScript.Parser.Declarations
25 PureScript.Parser.Common PureScript.Parser.Declarations
24 PureScript.Parser.Types PureScript.Parser.Values
26 PureScript.Parser.Types PureScript.Parser.Values
25 PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
27 PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
26− PureScript.TypeChecker.Types
28+ PureScript.TypeChecker.Types PureScript.Parser.State
27 exposed: True
29 exposed: True
28 buildable: True
30 buildable: True
29 hs-source-dirs: src
31 hs-source-dirs: src
30− other-modules:
31
32
32executable psc
33executable psc
33− build-depends: base -any, cmdtheline -any, containers -any,
34+ build-depends: base -any,
35+ cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
34− mtl -any, parsec -any, utf8-string -any
36+ utf8-string -any
35 main-is: Main.hs
37 main-is: Main.hs
36 buildable: True
38 buildable: True
37 hs-source-dirs: src
39 hs-source-dirs: src
38− other-modules:
40+
examples/Operators.ps+2
@@ -8,6 +8,8 @@ k = \x -> \y -> x
8
8
9test4 = 1 `k` 2
9test4 = 1 `k` 2
10
10
11+infixl 5 %%
12+
11(%%) = \x -> \y -> x * y + y
13(%%) = \x -> \y -> x * y + y
12
14
13test5 = 1 %% 2 %% 3
15test5 = 1 %% 2 %% 3
src/Main.hs+1−1
@@ -28,7 +28,7 @@ compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
28compile inputFiles outputFile externsFile = do
28compile inputFiles outputFile externsFile = do
29 asts <- fmap (fmap concat . sequence) $ flip mapM inputFiles $ \inputFile -> do
29 asts <- fmap (fmap concat . sequence) $ flip mapM inputFiles $ \inputFile -> do
30 text <- U.readFile inputFile
30 text <- U.readFile inputFile
31− return $ runIndentParser 0 parseDeclarations text
31+ return $ runIndentParser parseDeclarations text
32 case asts of
32 case asts of
33 Left err -> do
33 Left err -> do
34 U.print err
34 U.print err
src/PureScript/Declarations.hs+9−2
@@ -20,11 +20,18 @@ import PureScript.Values
20import PureScript.Types
20import PureScript.Types
21import PureScript.Names
21import PureScript.Names
22
22
23−import Data.Data
23+import qualified Data.Data as D
24+
25+type Precedence = Integer
26+
27+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
28+
29+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
24
30
25data Declaration
31data Declaration
26 = DataDeclaration String [String] [(String, Maybe Type)]
32 = DataDeclaration String [String] [(String, Maybe Type)]
27 | TypeSynonymDeclaration String [String] Type
33 | TypeSynonymDeclaration String [String] Type
28 | TypeDeclaration Ident PolyType
34 | TypeDeclaration Ident PolyType
29 | ValueDeclaration Ident Value
35 | ValueDeclaration Ident Value
30− | ExternDeclaration Ident PolyType deriving (Show, Data, Typeable)
36+ | ExternDeclaration Ident PolyType
37+ | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
src/PureScript/Parser/Common.hs+16−11
@@ -20,6 +20,8 @@ import Data.Char (isSpace)
20import Control.Applicative
20import Control.Applicative
21import Control.Monad
21import Control.Monad
22import Control.Monad.State
22import Control.Monad.State
23+import PureScript.Parser.State
24+import qualified Data.Map as M
23import qualified Text.Parsec as P
25import qualified Text.Parsec as P
24import qualified Text.Parsec.Pos as P
26import qualified Text.Parsec.Pos as P
25import qualified Text.Parsec.Token as PT
27import qualified Text.Parsec.Token as PT
@@ -66,7 +68,9 @@ reservedNames = [ "case"
66 , "with"
68 , "with"
67 , "Number"
69 , "Number"
68 , "String"
70 , "String"
69− , "Boolean" ]
71+ , "Boolean"
72+ , "infixl"
73+ , "infixr" ]
70
74
71reservedOpNames :: [String]
75reservedOpNames :: [String]
72reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
76reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
@@ -122,6 +126,7 @@ semiSep = PT.semiSep tokenParser
122semiSep1 = PT.semiSep1 tokenParser
126semiSep1 = PT.semiSep1 tokenParser
123commaSep = PT.commaSep tokenParser
127commaSep = PT.commaSep tokenParser
124commaSep1 = PT.commaSep1 tokenParser
128commaSep1 = PT.commaSep1 tokenParser
129+natural = PT.natural tokenParser
125
130
126tick :: P.Parsec String u Char
131tick :: P.Parsec String u Char
127tick = lexeme $ P.char '`'
132tick = lexeme $ P.char '`'
@@ -151,26 +156,26 @@ parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
151parseIdentInfix :: P.Parsec String u Ident
156parseIdentInfix :: P.Parsec String u Ident
152parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)
157parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)
153
158
154−mark :: P.Parsec String P.Column a -> P.Parsec String P.Column a
159+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
155mark p = do
160mark p = do
156− current <- P.getState
161+ current <- indentationLevel <$> P.getState
157 pos <- P.sourceColumn <$> P.getPosition
162 pos <- P.sourceColumn <$> P.getPosition
158− P.putState pos
163+ P.modifyState $ \st -> st { indentationLevel = pos }
159 a <- p
164 a <- p
160− P.putState current
165+ P.modifyState $ \st -> st { indentationLevel = current }
161 return a
166 return a
162
167
163−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String P.Column ()
168+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
164checkIndentation rel = (do
169checkIndentation rel = (do
165 col <- P.sourceColumn <$> P.getPosition
170 col <- P.sourceColumn <$> P.getPosition
166− current <- P.getState
171+ current <- indentationLevel <$> P.getState
167 guard $ col `rel` current) <|> P.parserFail "Indentation check"
172 guard $ col `rel` current) <|> P.parserFail "Indentation check"
168
173
169−indented :: P.Parsec String P.Column ()
174+indented :: P.Parsec String ParseState ()
170indented = checkIndentation (>)
175indented = checkIndentation (>)
171
176
172−same :: P.Parsec String P.Column ()
177+same :: P.Parsec String ParseState ()
173same = checkIndentation (==)
178same = checkIndentation (==)
174
179
175−runIndentParser :: P.Column -> P.Parsec String P.Column a -> String -> Either P.ParseError a
180+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
176−runIndentParser col p = P.runParser p 0 ""
181+runIndentParser p = P.runParser p (ParseState 0 M.empty) ""
src/PureScript/Parser/Declarations.hs+29−8
@@ -24,17 +24,19 @@ import Data.Function
24import Control.Applicative
24import Control.Applicative
25import Control.Arrow (Arrow(..))
25import Control.Arrow (Arrow(..))
26import Control.Monad.State
26import Control.Monad.State
27+import qualified Data.Map as M
27import qualified Text.Parsec as P
28import qualified Text.Parsec as P
28import qualified Text.Parsec.Pos as P
29import qualified Text.Parsec.Pos as P
29
30
30import PureScript.Values
31import PureScript.Values
31import PureScript.Types
32import PureScript.Types
33+import PureScript.Parser.State
32import PureScript.Parser.Common
34import PureScript.Parser.Common
33import PureScript.Declarations
35import PureScript.Declarations
34import PureScript.Parser.Values
36import PureScript.Parser.Values
35import PureScript.Parser.Types
37import PureScript.Parser.Types
36
38
37−parseDataDeclaration :: P.Parsec String P.Column Declaration
39+parseDataDeclaration :: P.Parsec String ParseState Declaration
38parseDataDeclaration = do
40parseDataDeclaration = do
39 reserved "data"
41 reserved "data"
40 name <- indented *> properName
42 name <- indented *> properName
@@ -43,34 +45,53 @@ parseDataDeclaration = do
43 ctors <- P.sepBy1 ((,) <$> (indented *> properName) <*> P.optionMaybe parseType) (lexeme $ indented *> P.char '|')
45 ctors <- P.sepBy1 ((,) <$> (indented *> properName) <*> P.optionMaybe parseType) (lexeme $ indented *> P.char '|')
44 return $ DataDeclaration name tyArgs ctors
46 return $ DataDeclaration name tyArgs ctors
45
47
46−parseTypeDeclaration :: P.Parsec String P.Column Declaration
48+parseTypeDeclaration :: P.Parsec String ParseState Declaration
47parseTypeDeclaration =
49parseTypeDeclaration =
48 TypeDeclaration <$> parseIdent
50 TypeDeclaration <$> parseIdent
49 <*> (lexeme (indented *> P.string "::") *> parsePolyType)
51 <*> (lexeme (indented *> P.string "::") *> parsePolyType)
50
52
51−parseTypeSynonymDeclaration :: P.Parsec String P.Column Declaration
53+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
52parseTypeSynonymDeclaration =
54parseTypeSynonymDeclaration =
53 TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
55 TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
54 <*> many (indented *> identifier)
56 <*> many (indented *> identifier)
55 <*> (lexeme (indented *> P.char '=') *> parseType)
57 <*> (lexeme (indented *> P.char '=') *> parseType)
56
58
57−parseValueDeclaration :: P.Parsec String P.Column Declaration
59+parseValueDeclaration :: P.Parsec String ParseState Declaration
58parseValueDeclaration =
60parseValueDeclaration =
59 ValueDeclaration <$> parseIdent
61 ValueDeclaration <$> parseIdent
60 <*> (lexeme (indented *> P.char '=') *> parseValue)
62 <*> (lexeme (indented *> P.char '=') *> parseValue)
61
63
62−parseExternDeclaration :: P.Parsec String P.Column Declaration
64+parseExternDeclaration :: P.Parsec String ParseState Declaration
63parseExternDeclaration =
65parseExternDeclaration =
64 ExternDeclaration <$> (reserved "extern" *> indented *> parseIdent)
66 ExternDeclaration <$> (reserved "extern" *> indented *> parseIdent)
65 <*> (lexeme (indented *> P.string "::") *> parsePolyType)
67 <*> (lexeme (indented *> P.string "::") *> parsePolyType)
66
68
69+parseAssociativity :: P.Parsec String ParseState Associativity
70+parseAssociativity =
71+ (reserved "infixl" >> return Infixl) <|>
72+ (reserved "infixr" >> return Infixr)
73+
74+parseFixity :: P.Parsec String ParseState Fixity
75+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
76+
77+parseFixityDeclaration :: P.Parsec String ParseState Declaration
78+parseFixityDeclaration = do
79+ fixity <- parseFixity
80+ indented
81+ name <- operator
82+ current <- fixities <$> P.getState
83+ when (name `M.member` current) (P.unexpected $ "redefined fixity for " ++ show name)
84+ P.modifyState $ \st -> st { fixities = M.insert name fixity current }
85+ return $ FixityDeclaration fixity name
86+
67−parseDeclaration :: P.Parsec String P.Column Declaration
87+parseDeclaration :: P.Parsec String ParseState Declaration
68parseDeclaration = P.choice $ map P.try
88parseDeclaration = P.choice $ map P.try
69 [ parseDataDeclaration
89 [ parseDataDeclaration
70 , parseTypeDeclaration
90 , parseTypeDeclaration
71 , parseTypeSynonymDeclaration
91 , parseTypeSynonymDeclaration
72 , parseValueDeclaration
92 , parseValueDeclaration
73− , parseExternDeclaration ]
93+ , parseExternDeclaration
94+ , parseFixityDeclaration ]
74
95
75−parseDeclarations :: P.Parsec String P.Column [Declaration]
96+parseDeclarations :: P.Parsec String ParseState [Declaration]
76parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof
97parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof
src/PureScript/Parser/State.hsnew file+27
@@ -0,0 +1,27 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.Parser.State
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+module PureScript.Parser.State where
16+
17+import PureScript.Names
18+import PureScript.Declarations
19+
20+import qualified Text.Parsec as P
21+import qualified Data.Map as M
22+
23+data ParseState = ParseState
24+ { indentationLevel :: P.Column
25+ , fixities :: M.Map String Fixity } deriving Show
26+
27+
src/PureScript/Parser/Types.hs+16−15
@@ -19,41 +19,42 @@ module PureScript.Parser.Types (
19) where
19) where
20
20
21import PureScript.Types
21import PureScript.Types
22+import PureScript.Parser.State
22import PureScript.Parser.Common
23import PureScript.Parser.Common
23import Control.Applicative
24import Control.Applicative
24import qualified Text.Parsec as P
25import qualified Text.Parsec as P
25import qualified Text.Parsec.Expr as P
26import qualified Text.Parsec.Expr as P
26import Control.Arrow (Arrow(..))
27import Control.Arrow (Arrow(..))
27
28
28−parseNumber :: P.Parsec String P.Column Type
29+parseNumber :: P.Parsec String ParseState Type
29parseNumber = const Number <$> reserved "Number"
30parseNumber = const Number <$> reserved "Number"
30
31
31−parseString :: P.Parsec String P.Column Type
32+parseString :: P.Parsec String ParseState Type
32parseString = const String <$> reserved "String"
33parseString = const String <$> reserved "String"
33
34
34−parseBoolean :: P.Parsec String P.Column Type
35+parseBoolean :: P.Parsec String ParseState Type
35parseBoolean = const Boolean <$> reserved "Boolean"
36parseBoolean = const Boolean <$> reserved "Boolean"
36
37
37−parseArray :: P.Parsec String P.Column Type
38+parseArray :: P.Parsec String ParseState Type
38parseArray = squares $ Array <$> parseType
39parseArray = squares $ Array <$> parseType
39
40
40−parseObject :: P.Parsec String P.Column Type
41+parseObject :: P.Parsec String ParseState Type
41parseObject = braces $ Object <$> parseRow
42parseObject = braces $ Object <$> parseRow
42
43
43−parseFunction :: P.Parsec String P.Column Type
44+parseFunction :: P.Parsec String ParseState Type
44parseFunction = do
45parseFunction = do
45 args <- lexeme $ parens $ commaSep parseType
46 args <- lexeme $ parens $ commaSep parseType
46 lexeme $ P.string "->"
47 lexeme $ P.string "->"
47 resultType <- parseType
48 resultType <- parseType
48 return $ Function args resultType
49 return $ Function args resultType
49
50
50−parseTypeVariable :: P.Parsec String P.Column Type
51+parseTypeVariable :: P.Parsec String ParseState Type
51parseTypeVariable = TypeVar <$> identifier
52parseTypeVariable = TypeVar <$> identifier
52
53
53−parseTypeConstructor :: P.Parsec String P.Column Type
54+parseTypeConstructor :: P.Parsec String ParseState Type
54parseTypeConstructor = TypeConstructor <$> properName
55parseTypeConstructor = TypeConstructor <$> properName
55
56
56−parseTypeAtom :: P.Parsec String P.Column Type
57+parseTypeAtom :: P.Parsec String ParseState Type
57parseTypeAtom = indented *> P.choice (map P.try
58parseTypeAtom = indented *> P.choice (map P.try
58 [ parseNumber
59 [ parseNumber
59 , parseString
60 , parseString
@@ -65,24 +66,24 @@ parseTypeAtom = indented *> P.choice (map P.try
65 , parseTypeConstructor
66 , parseTypeConstructor
66 , parens parseType ])
67 , parens parseType ])
67
68
68−parsePolyType :: P.Parsec String P.Column PolyType
69+parsePolyType :: P.Parsec String ParseState PolyType
69parsePolyType = PolyType <$> (P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot))
70parsePolyType = PolyType <$> (P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot))
70 <*> parseType
71 <*> parseType
71
72
72−parseType :: P.Parsec String P.Column Type
73+parseType :: P.Parsec String ParseState Type
73parseType = P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom
74parseType = P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom
74 where
75 where
75− postfixTable :: [P.Parsec String P.Column (Type -> Type)]
76+ postfixTable :: [P.Parsec String ParseState (Type -> Type)]
76 postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ]
77 postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ]
77 operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
78 operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
78
79
79−parseNameAndType :: P.Parsec String P.Column (String, Type)
80+parseNameAndType :: P.Parsec String ParseState (String, Type)
80parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
81parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
81
82
82−parseRowEnding :: P.Parsec String P.Column Row
83+parseRowEnding :: P.Parsec String ParseState Row
83parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
84parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
84
85
85−parseRow :: P.Parsec String P.Column Row
86+parseRow :: P.Parsec String ParseState Row
86parseRow = fromList <$> (parseNameAndType `P.sepBy` (indented *> semi)) <*> parseRowEnding
87parseRow = fromList <$> (parseNameAndType `P.sepBy` (indented *> semi)) <*> parseRowEnding
87 where
88 where
88 fromList :: [(String, Type)] -> Row -> Row
89 fromList :: [(String, Type)] -> Row -> Row
src/PureScript/Parser/Values.hs+74−46
@@ -18,6 +18,13 @@ module PureScript.Parser.Values (
18) where
18) where
19
19
20import PureScript.Values
20import PureScript.Values
21+import PureScript.Names
22+import PureScript.Declarations
23+import PureScript.Parser.State
24+import Data.Function (on)
25+import Data.List
26+import Data.Functor.Identity
27+import qualified Data.Map as M
21import qualified PureScript.Parser.Common as C
28import qualified PureScript.Parser.Common as C
22import Control.Applicative
29import Control.Applicative
23import qualified Text.Parsec as P
30import qualified Text.Parsec as P
@@ -27,29 +34,29 @@ import Control.Arrow (Arrow(..))
27import PureScript.Parser.Types
34import PureScript.Parser.Types
28import PureScript.Types
35import PureScript.Types
29
36
30−booleanLiteral :: P.Parsec String P.Column Bool
37+booleanLiteral :: P.Parsec String ParseState Bool
31booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
38booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
32
39
33−parseNumericLiteral :: P.Parsec String P.Column Value
40+parseNumericLiteral :: P.Parsec String ParseState Value
34parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
41parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
35
42
36−parseStringLiteral :: P.Parsec String P.Column Value
43+parseStringLiteral :: P.Parsec String ParseState Value
37parseStringLiteral = StringLiteral <$> C.stringLiteral
44parseStringLiteral = StringLiteral <$> C.stringLiteral
38
45
39−parseBooleanLiteral :: P.Parsec String P.Column Value
46+parseBooleanLiteral :: P.Parsec String ParseState Value
40parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
47parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
41
48
42−parseArrayLiteral :: P.Parsec String P.Column Value
49+parseArrayLiteral :: P.Parsec String ParseState Value
43parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))
50parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))
44
51
45−parseObjectLiteral :: P.Parsec String P.Column Value
52+parseObjectLiteral :: P.Parsec String ParseState Value
46parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))
53parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))
47
54
48−parseIdentifierAndValue :: P.Parsec String P.Column (String, Value)
55+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
49parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
56parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
50 <*> (C.indented *> parseValue)
57 <*> (C.indented *> parseValue)
51
58
52−parseAbs :: P.Parsec String P.Column Value
59+parseAbs :: P.Parsec String ParseState Value
53parseAbs = do
60parseAbs = do
54 C.lexeme $ P.char '\\'
61 C.lexeme $ P.char '\\'
55 args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
62 args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
@@ -57,35 +64,35 @@ parseAbs = do
57 value <- parseValue
64 value <- parseValue
58 return $ Abs args value
65 return $ Abs args value
59
66
60−parseApp :: P.Parsec String P.Column Value
67+parseApp :: P.Parsec String ParseState Value
61parseApp = App <$> parseValue
68parseApp = App <$> parseValue
62 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
69 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
63
70
64−parseVar :: P.Parsec String P.Column Value
71+parseVar :: P.Parsec String ParseState Value
65parseVar = Var <$> C.parseIdent
72parseVar = Var <$> C.parseIdent
66
73
67−parseConstructor :: P.Parsec String P.Column Value
74+parseConstructor :: P.Parsec String ParseState Value
68parseConstructor = Constructor <$> C.properName
75parseConstructor = Constructor <$> C.properName
69
76
70−parseCase :: P.Parsec String P.Column Value
77+parseCase :: P.Parsec String ParseState Value
71parseCase = Case <$> (P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue)
78parseCase = Case <$> (P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue)
72 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
79 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
73
80
74−parseCaseAlternative :: P.Parsec String P.Column (Binder, Value)
81+parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
75parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->")) <*> parseValue
82parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->")) <*> parseValue
76
83
77−parseIfThenElse :: P.Parsec String P.Column Value
84+parseIfThenElse :: P.Parsec String ParseState Value
78parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)
85parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)
79 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
86 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
80 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
87 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
81−
88+
82−parseBlock :: P.Parsec String P.Column Value
89+parseBlock :: P.Parsec String ParseState Value
83parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)
90parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)
84
91
85−parseManyStatements :: P.Parsec String P.Column [Statement]
92+parseManyStatements :: P.Parsec String ParseState [Statement]
86parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement)
93parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement)
87
94
88−parseValueAtom :: P.Parsec String P.Column Value
95+parseValueAtom :: P.Parsec String ParseState Value
89parseValueAtom = C.indented *> P.choice (map P.try
96parseValueAtom = C.indented *> P.choice (map P.try
90 [ parseNumericLiteral
97 [ parseNumericLiteral
91 , parseStringLiteral
98 , parseStringLiteral
@@ -100,8 +107,10 @@ parseValueAtom = C.indented *> P.choice (map P.try
100 , parseIfThenElse
107 , parseIfThenElse
101 , C.parens parseValue ])
108 , C.parens parseValue ])
102
109
103−parseValue :: P.Parsec String P.Column Value
110+parseValue :: P.Parsec String ParseState Value
111+parseValue = do
112+ customOps <- fixities <$> P.getState
104−parseValue = buildExpressionParser operators . C.buildPostfixParser postfixTable2 $ indexersAndAccessors
113+ buildExpressionParser (operators customOps) . C.buildPostfixParser postfixTable2 $ indexersAndAccessors
105 where
114 where
106 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom
115 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom
107 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
116 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
@@ -109,11 +118,13 @@ parseValue = buildExpressionParser operators . C.buildPostfixParser postfixTable
109 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])
118 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])
110 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
119 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
111 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]
120 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]
121+ operators user =
112− operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
122+ [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
113 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
123 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
114 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
124 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
115 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
125 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
126+ ] ++ customOperatorTable user ++
116− , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix) >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]
127+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix) >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]
117 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
128 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
118 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
129 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
119 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
130 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
@@ -136,7 +147,24 @@ parseValue = buildExpressionParser operators . C.buildPostfixParser postfixTable
136 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
147 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
137 ]
148 ]
138
149
150+customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value
151+customOperatorTable fixities =
152+ let
153+ ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities
154+ sorted = sortBy (compare `on` (snd . snd)) ops
155+ levels = groupBy ((==) `on` (snd . snd)) sorted
156+ in
157+ flip map levels (map (\(name, (a, _)) -> flip Infix (toAssoc a) $ do
158+ C.lexeme $ P.try $ do
159+ C.indented
160+ C.reservedOp name
161+ return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]))
162+
163+toAssoc :: Associativity -> Assoc
164+toAssoc Infixl = AssocLeft
165+toAssoc Infixr = AssocRight
166+
139−parseVariableIntroduction :: P.Parsec String P.Column Statement
167+parseVariableIntroduction :: P.Parsec String ParseState Statement
140parseVariableIntroduction = do
168parseVariableIntroduction = do
141 C.reserved "var"
169 C.reserved "var"
142 name <- C.indented *> C.parseIdent
170 name <- C.indented *> C.parseIdent
@@ -144,45 +172,45 @@ parseVariableIntroduction = do
144 value <- parseValue
172 value <- parseValue
145 return $ VariableIntroduction name value
173 return $ VariableIntroduction name value
146
174
147−parseAssignment :: P.Parsec String P.Column Statement
175+parseAssignment :: P.Parsec String ParseState Statement
148parseAssignment = do
176parseAssignment = do
149 tgt <- parseAssignmentTarget
177 tgt <- parseAssignmentTarget
150 C.lexeme $ C.indented *> P.char '='
178 C.lexeme $ C.indented *> P.char '='
151 value <- parseValue
179 value <- parseValue
152 return $ Assignment tgt value
180 return $ Assignment tgt value
153
181
154−parseWhile :: P.Parsec String P.Column Statement
182+parseWhile :: P.Parsec String ParseState Statement
155parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
183parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
156 <*> parseManyStatements
184 <*> parseManyStatements
157
185
158−parseFor :: P.Parsec String P.Column Statement
186+parseFor :: P.Parsec String ParseState Statement
159parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
187parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
160 <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
188 <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
161 <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
189 <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
162 <*> parseManyStatements
190 <*> parseManyStatements
163
191
164−parseForEach :: P.Parsec String P.Column Statement
192+parseForEach :: P.Parsec String ParseState Statement
165parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
193parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
166 <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
194 <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
167 <*> parseManyStatements
195 <*> parseManyStatements
168
196
169−parseIf :: P.Parsec String P.Column Statement
197+parseIf :: P.Parsec String ParseState Statement
170parseIf = If <$> parseIfStatement
198parseIf = If <$> parseIfStatement
171
199
172−parseIfStatement :: P.Parsec String P.Column IfStatement
200+parseIfStatement :: P.Parsec String ParseState IfStatement
173parseIfStatement =
201parseIfStatement =
174 IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
202 IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
175 <*> parseManyStatements
203 <*> parseManyStatements
176 <*> P.optionMaybe (C.same *> parseElseStatement)
204 <*> P.optionMaybe (C.same *> parseElseStatement)
177
205
178−parseElseStatement :: P.Parsec String P.Column ElseStatement
206+parseElseStatement :: P.Parsec String ParseState ElseStatement
179parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
207parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
180 <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
208 <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
181
209
182−parseReturn :: P.Parsec String P.Column Statement
210+parseReturn :: P.Parsec String ParseState Statement
183parseReturn = Return <$> (C.reserved "return" *> parseValue)
211parseReturn = Return <$> (C.reserved "return" *> parseValue)
184
212
185−parseStatement :: P.Parsec String P.Column Statement
213+parseStatement :: P.Parsec String ParseState Statement
186parseStatement = P.choice (map P.try
214parseStatement = P.choice (map P.try
187 [ parseVariableIntroduction
215 [ parseVariableIntroduction
188 , parseAssignment
216 , parseAssignment
@@ -192,46 +220,46 @@ parseStatement = P.choice (map P.try
192 , parseIf
220 , parseIf
193 , parseReturn ])
221 , parseReturn ])
194
222
195−parseStringBinder :: P.Parsec String P.Column Binder
223+parseStringBinder :: P.Parsec String ParseState Binder
196parseStringBinder = StringBinder <$> C.stringLiteral
224parseStringBinder = StringBinder <$> C.stringLiteral
197
225
198−parseBooleanBinder :: P.Parsec String P.Column Binder
226+parseBooleanBinder :: P.Parsec String ParseState Binder
199parseBooleanBinder = BooleanBinder <$> booleanLiteral
227parseBooleanBinder = BooleanBinder <$> booleanLiteral
200
228
201−parseNumberBinder :: P.Parsec String P.Column Binder
229+parseNumberBinder :: P.Parsec String ParseState Binder
202parseNumberBinder = NumberBinder <$> C.integerOrFloat
230parseNumberBinder = NumberBinder <$> C.integerOrFloat
203
231
204−parseVarBinder :: P.Parsec String P.Column Binder
232+parseVarBinder :: P.Parsec String ParseState Binder
205parseVarBinder = VarBinder <$> C.parseIdent
233parseVarBinder = VarBinder <$> C.parseIdent
206
234
207−parseNullaryBinder :: P.Parsec String P.Column Binder
235+parseNullaryBinder :: P.Parsec String ParseState Binder
208parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
236parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
209
237
210−parseUnaryBinder :: P.Parsec String P.Column Binder
238+parseUnaryBinder :: P.Parsec String ParseState Binder
211parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
239parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
212
240
213−parseObjectBinder :: P.Parsec String P.Column Binder
241+parseObjectBinder :: P.Parsec String ParseState Binder
214parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
242parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
215
243
216−parseArrayBinder :: P.Parsec String P.Column Binder
244+parseArrayBinder :: P.Parsec String ParseState Binder
217parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))
245parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))
218 <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
246 <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
219
247
220−parseNamedBinder :: P.Parsec String P.Column Binder
248+parseNamedBinder :: P.Parsec String ParseState Binder
221parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
249parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
222 <*> (C.indented *> parseBinder)
250 <*> (C.indented *> parseBinder)
223
251
224−parseNullBinder :: P.Parsec String P.Column Binder
252+parseNullBinder :: P.Parsec String ParseState Binder
225parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
253parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
226
254
227−parseIdentifierAndBinder :: P.Parsec String P.Column (String, Binder)
255+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
228parseIdentifierAndBinder = do
256parseIdentifierAndBinder = do
229 name <- C.lexeme C.identifier
257 name <- C.lexeme C.identifier
230 C.lexeme $ C.indented *> P.char '='
258 C.lexeme $ C.indented *> P.char '='
231 binder <- C.indented *> parseBinder
259 binder <- C.indented *> parseBinder
232 return (name, binder)
260 return (name, binder)
233
261
234−parseBinder :: P.Parsec String P.Column Binder
262+parseBinder :: P.Parsec String ParseState Binder
235parseBinder = P.choice (map P.try
263parseBinder = P.choice (map P.try
236 [ parseNullBinder
264 [ parseNullBinder
237 , parseStringBinder
265 , parseStringBinder
@@ -245,10 +273,10 @@ parseBinder = P.choice (map P.try
245 , parseArrayBinder
273 , parseArrayBinder
246 , C.parens parseBinder ])
274 , C.parens parseBinder ])
247
275
248−parseGuardedBinder :: P.Parsec String P.Column Binder
276+parseGuardedBinder :: P.Parsec String ParseState Binder
249parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
277parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
250
278
251−parseAssignmentTarget :: P.Parsec String P.Column AssignmentTarget
279+parseAssignmentTarget :: P.Parsec String ParseState AssignmentTarget
252parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)
280parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)
253 where
281 where
254 operators = [ [ Postfix $ AssignArrayIndex <$> (C.indented *> C.squares parseValue)
282 operators = [ [ Postfix $ AssignArrayIndex <$> (C.indented *> C.squares parseValue)
src/PureScript/TypeChecker.hs+6
@@ -29,9 +29,11 @@ import PureScript.TypeChecker.Synonyms
29import Data.List
29import Data.List
30import Data.Maybe
30import Data.Maybe
31import Data.Function
31import Data.Function
32+import qualified Data.Map as M
32
33
33import PureScript.Values
34import PureScript.Values
34import PureScript.Types
35import PureScript.Types
36+import PureScript.Names
35import PureScript.Kinds
37import PureScript.Kinds
36import PureScript.Declarations
38import PureScript.Declarations
37
39
@@ -86,3 +88,7 @@ typeCheckAll (ExternDeclaration name ty : rest) = do
86 Just _ -> throwError $ show name ++ " is already defined"
88 Just _ -> throwError $ show name ++ " is already defined"
87 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
89 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
88 typeCheckAll rest
90 typeCheckAll rest
91+typeCheckAll (FixityDeclaration _ name : rest) = do
92+ typeCheckAll rest
93+ env <- getEnv
94+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env