1b77d7e · rowtype-yoga/purescript-native

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

on golang help sign in

hlint

1b77d7ePhil Freeman13 years ago

PureScript.cabal+18−17

compare with golang

unifiedsplit

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.0.1

2+version: 0.1.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -11,9 +11,9 @@ 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,

16+ build-depends: base >=4 && <5, syb -any, cmdtheline -any,

17 containers -any, mtl -any, transformers -any, parsec -any,

18 utf8-string -any

19 exposed-modules: PureScript.CodeGen.Pretty.Values

@@ -31,21 +31,22 @@ library

31 exposed: True

32 buildable: True

33 hs-source-dirs: src

34− other-modules:

34+ other-modules: PureScript.Pretty

35−

35+

36−Test-Suite tests

37− type: exitcode-stdio-1.0

38− main-is: Main.hs

39− hs-source-dirs: tests

40− build-depends: base -any, syb -any, directory -any, filepath -any,

41− containers -any, mtl -any, transformers -any, parsec -any,

42− utf8-string -any, purescript -any

43−

44executable psc

36executable psc

45− build-depends: base -any, cmdtheline -any, containers -any,

37+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,

46− mtl -any, transformers -any, parsec -any, utf8-string -any, syb -any

38+ mtl -any, transformers -any, parsec -any, utf8-string -any,

39+ syb -any

47 main-is: Main.hs

40 main-is: Main.hs

48 buildable: True

41 buildable: True

49 hs-source-dirs: src

42 hs-source-dirs: src

50− other-modules:

43+ other-modules: PureScript.Pretty

51−

44+

45+test-suite tests

46+ build-depends: base >=4 && <5, syb -any, directory -any,

47+ filepath -any, containers -any, mtl -any, transformers -any,

48+ parsec -any, utf8-string -any, purescript -any

49+ type: exitcode-stdio-1.0

50+ main-is: Main.hs

51+ buildable: True

52+ hs-source-dirs: tests

src/Main.hs+3−2

@@ -19,6 +19,7 @@ import Data.Maybe (mapMaybe)

19import Data.List (intercalate)

20import System.Console.CmdTheLine

21import Control.Applicative

22+import Control.Monad (forM)

22import System.Exit (exitSuccess, exitFailure)

23import System.Exit (exitSuccess, exitFailure)

23import qualified Text.Parsec as P

24import qualified Text.Parsec as P

24import qualified System.IO.UTF8 as U

25import qualified System.IO.UTF8 as U

@@ -26,14 +27,14 @@ import qualified Data.Map as M

27compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

28compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

28compile inputFiles outputFile externsFile = do

29compile inputFiles outputFile externsFile = do

29− asts <- fmap (fmap concat . sequence) $ flip mapM inputFiles $ \inputFile -> do

30+ asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do

30 text <- U.readFile inputFile

31 text <- U.readFile inputFile

31 return $ runIndentParser parseDeclarations text

32 return $ runIndentParser parseDeclarations text

32 case asts of

33 case asts of

33 Left err -> do

34 Left err -> do

34 U.print err

35 U.print err

35 exitFailure

36 exitFailure

36− Right decls -> do

37+ Right decls ->

37 case check (typeCheckAll decls) of

38 case check (typeCheckAll decls) of

38 Left typeError -> do

39 Left typeError -> do

39 U.putStrLn typeError

40 U.putStrLn typeError

src/PureScript.hs+11−18

@@ -12,22 +12,15 @@

12--

13-----------------------------------------------------------------------------

15−module PureScript (

15+module PureScript (module P) where

16+

16− module PureScript.Values,

17+import PureScript.Values as P

17− module PureScript.Types,

18+import PureScript.Types as P

18− module PureScript.Kinds,

19+import PureScript.Kinds as P

19− module PureScript.Declarations,

20+import PureScript.Declarations as P

20− module PureScript.Names,

21+import PureScript.Names as P

21− module PureScript.Parser,

22+import PureScript.Parser as P

22− module PureScript.CodeGen,

23+import PureScript.CodeGen as P

23− module PureScript.TypeChecker

24+import PureScript.TypeChecker as P

24−) where

25+import PureScript.Pretty as P

26−import PureScript.Values

27−import PureScript.Types

28−import PureScript.Kinds

29−import PureScript.Declarations

30−import PureScript.Names

31−import PureScript.Parser

32−import PureScript.CodeGen

33−import PureScript.TypeChecker

src/PureScript/CodeGen/Common.hs+4−4

@@ -51,16 +51,16 @@ parens :: String -> String

51parens s = ('(':s) ++ ")"

53chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

54−chainl split f p = fix $ \c -> (split >>> ((c <+> p) *** p) >>> A.arr (uncurry f))

54+chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)

56chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

57−chainr split f p = fix $ \c -> (split >>> (p *** (c <+> p)) >>> A.arr (uncurry f))

57+chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)

59wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r

60−wrap split f p = fix $ \c -> (split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f))

60+wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)

62split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r

63−split s f p = (s >>> A.arr (uncurry f))

63+split s f p = s >>> A.arr (uncurry f)

65data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }

src/PureScript/CodeGen/Common/Gen.hs+1−1

@@ -28,4 +28,4 @@ fresh :: Gen String

28fresh = do

29 n <- get

30 modify (+ 1)

31− return $ "_" ++ show n

31+ return $ '_' : show n

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

@@ -32,5 +32,5 @@ externToPs env (ExternDeclaration name ty) =

32externToPs env (ExternDataDeclaration name kind) =

33 return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind

34externToPs env (TypeSynonymDeclaration name args ty) =

35− return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty

35+ return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

36externToPs _ _ = Nothing

src/PureScript/CodeGen/JS.hs+30−29

@@ -21,6 +21,7 @@ import Data.Maybe (fromMaybe)

21import Data.List (intercalate)

22import qualified Control.Arrow as A

23import Control.Arrow ((<+>))

24+import Control.Monad (forM)

24import Control.Applicative

25import Control.Applicative

26import PureScript.Types

27import PureScript.Types

@@ -59,7 +60,7 @@ literals = Pattern $ A.Kleisli match

59 bindersToJs :: [(Binder, Value)] -> Gen String

60 bindersToJs :: [(Binder, Value)] -> Gen String

60 bindersToJs binders = do

61 bindersToJs binders = do

61 valName <- fresh

62 valName <- fresh

62− jss <- flip mapM binders $ \(binder, result) -> do

63+ jss <- forM binders $ \(binder, result) -> do

63 let js = valueToJs result

64 let js = valueToJs result

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

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

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

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

@@ -121,34 +122,34 @@ valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

121 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

122 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

122 operators :: OperatorTable Value String

123 operators :: OperatorTable Value String

123 operators =

124 operators =

124− OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

125+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

125− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

126+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

126− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

127+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

127− , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]

128+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]

128− , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]

129+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]

129− , [ binary LessThan "<" ]

130+ , [ binary LessThan "<" ]

130− , [ binary LessThanOrEqualTo "<=" ]

131+ , [ binary LessThanOrEqualTo "<=" ]

131− , [ binary GreaterThan ">" ]

132+ , [ binary GreaterThan ">" ]

132− , [ binary GreaterThanOrEqualTo ">=" ]

133+ , [ binary GreaterThanOrEqualTo ">=" ]

133− , [ unary Not "!" ]

134+ , [ unary Not "!" ]

134− , [ unary BitwiseNot "~" ]

135+ , [ unary BitwiseNot "~" ]

135− , [ unary Negate "-" ]

136+ , [ unary Negate "-" ]

136− , [ binary Multiply "*" ]

137+ , [ binary Multiply "*" ]

137− , [ binary Divide "/" ]

138+ , [ binary Divide "/" ]

138− , [ binary Modulus "%" ]

139+ , [ binary Modulus "%" ]

139− , [ binary Concat "+" ]

140+ , [ binary Concat "+" ]

140− , [ binary Add "+" ]

141+ , [ binary Add "+" ]

141− , [ binary Subtract "-" ]

142+ , [ binary Subtract "-" ]

142− , [ binary ShiftLeft "<<" ]

143+ , [ binary ShiftLeft "<<" ]

143− , [ binary ShiftRight ">>" ]

144+ , [ binary ShiftRight ">>" ]

144− , [ binary ZeroFillShiftRight ">>>" ]

145+ , [ binary ZeroFillShiftRight ">>>" ]

145− , [ binary EqualTo "===" ]

146+ , [ binary EqualTo "===" ]

146− , [ binary NotEqualTo "!==" ]

147+ , [ binary NotEqualTo "!==" ]

147− , [ binary BitwiseAnd "&" ]

148+ , [ binary BitwiseAnd "&" ]

148− , [ binary BitwiseXor "^" ]

149+ , [ binary BitwiseXor "^" ]

149− , [ binary BitwiseOr "|" ]

150+ , [ binary BitwiseOr "|" ]

150− , [ binary And "&&" ]

151+ , [ binary And "&&" ]

151− , [ binary Or "||" ]

152+ , [ binary Or "||" ]

152 ]

153 ]

153

154

154binderToJs :: String -> String -> Binder -> Gen String

155binderToJs :: String -> String -> Binder -> Gen String

src/PureScript/CodeGen/Pretty/Kinds.hs+2−2

@@ -31,7 +31,7 @@ typeLiterals = Pattern $ A.Kleisli match

31 where

32 match Star = Just "*"

33 match Row = Just "#"

34− match (KUnknown u) = Just $ "u" ++ show u

34+ match (KUnknown u) = Just $ 'u' : show u

35 match _ = Nothing

37funKind :: Pattern Kind (Kind, Kind)

@@ -47,4 +47,4 @@ prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind

47 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

48 operators :: OperatorTable Kind String

49 operators =

50− OperatorTable $ [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

50+ OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

src/PureScript/CodeGen/Pretty/Types.hs+6−6

@@ -42,7 +42,7 @@ typeLiterals = Pattern $ A.Kleisli match

42 match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

43 match (TypeVar var) = Just var

44 match (TypeConstructor ctor) = Just ctor

45− match (TUnknown u) = Just $ "u" ++ show u

45+ match (TUnknown u) = Just $ 'u' : show u

46 match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

47 match _ = Nothing

@@ -84,12 +84,12 @@ prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType

84 matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)

85 operators :: OperatorTable Type String

86 operators =

87− OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

87+ OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

88− , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

88+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

89− , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

89+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

90− ]

91 ]

90 ]

91+ ]

93prettyPrintPolyType :: PolyType -> String

94prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty

95−prettyPrintPolyType (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ prettyPrintType ty

95+prettyPrintPolyType (PolyType idents ty) = "forall " ++ unwords idents ++ ". " ++ prettyPrintType ty

src/PureScript/CodeGen/Pretty/Values.hs+30−30

@@ -108,36 +108,36 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue

108 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

109 operators :: OperatorTable Value String

110 operators =

111− OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

111+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

112− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

112+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

113− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

113+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

114− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

114+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

115− , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]

115+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]

116− , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

116+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

117− , [ binary LessThan "<" ]

117+ , [ binary LessThan "<" ]

118− , [ binary LessThanOrEqualTo "<=" ]

118+ , [ binary LessThanOrEqualTo "<=" ]

119− , [ binary GreaterThan ">" ]

119+ , [ binary GreaterThan ">" ]

120− , [ binary GreaterThanOrEqualTo ">=" ]

120+ , [ binary GreaterThanOrEqualTo ">=" ]

121− , [ unary Not "!" ]

121+ , [ unary Not "!" ]

122− , [ unary BitwiseNot "~" ]

122+ , [ unary BitwiseNot "~" ]

123− , [ unary Negate "-" ]

123+ , [ unary Negate "-" ]

124− , [ binary Multiply "*" ]

124+ , [ binary Multiply "*" ]

125− , [ binary Divide "/" ]

125+ , [ binary Divide "/" ]

126− , [ binary Modulus "%" ]

126+ , [ binary Modulus "%" ]

127− , [ binary Concat "++" ]

127+ , [ binary Concat "++" ]

128− , [ binary Add "+" ]

128+ , [ binary Add "+" ]

129− , [ binary Subtract "-" ]

129+ , [ binary Subtract "-" ]

130− , [ binary ShiftLeft "<<" ]

130+ , [ binary ShiftLeft "<<" ]

131− , [ binary ShiftRight ">>" ]

131+ , [ binary ShiftRight ">>" ]

132− , [ binary ZeroFillShiftRight ">>>" ]

132+ , [ binary ZeroFillShiftRight ">>>" ]

133− , [ binary EqualTo "==" ]

133+ , [ binary EqualTo "==" ]

134− , [ binary NotEqualTo "!=" ]

134+ , [ binary NotEqualTo "!=" ]

135− , [ binary BitwiseAnd "&" ]

135+ , [ binary BitwiseAnd "&" ]

136− , [ binary BitwiseXor "^" ]

136+ , [ binary BitwiseXor "^" ]

137− , [ binary BitwiseOr "|" ]

137+ , [ binary BitwiseOr "|" ]

138− , [ binary And "&&" ]

138+ , [ binary And "&&" ]

139− , [ binary Or "||" ]

139+ , [ binary Or "||" ]

140− ]

140+ ]

141

142prettyPrintBinder :: Binder -> String

143prettyPrintBinder NullBinder = "_"

src/PureScript/Parser.hs+7−11

@@ -12,15 +12,11 @@

12--

13-----------------------------------------------------------------------------

15−module PureScript.Parser (

15+module PureScript.Parser (module P) where

16− module PureScript.Parser.Common,

17− module PureScript.Parser.Types,

18− module PureScript.Parser.Values,

19− module PureScript.Parser.Declarations

20−) where

21−

22−import PureScript.Parser.Common

23−import PureScript.Parser.Types

24−import PureScript.Parser.Values

25−import PureScript.Parser.Declarations

17+import PureScript.Parser.Common as P

18+import PureScript.Parser.Types as P

19+import PureScript.Parser.Values as P

20+import PureScript.Parser.State as P

21+import PureScript.Parser.Kinds as P

22+import PureScript.Parser.Declarations as P

src/PureScript/Parser/Common.hs+1−1

@@ -139,7 +139,7 @@ integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>

139 Right <$> P.try (PT.float tokenParser)) P.<?> "number"

140

141augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

142−augment p q f = (flip $ maybe id $ flip f) <$> p <*> P.optionMaybe q

142+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

143

144fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

145fold first more combine = do

src/PureScript/Parser/Types.hs+1−1

@@ -67,7 +67,7 @@ parseTypeAtom = indented *> P.choice (map P.try

67 , parens parseType ])

69parsePolyType :: P.Parsec String ParseState PolyType

70−parsePolyType = (PolyType <$> (P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot))

70+parsePolyType = (PolyType <$> P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot)

71 <*> parseType) P.<?> "polymorphic type"

73parseType :: P.Parsec String ParseState Type

src/PureScript/Parser/Values.hs+14−11

@@ -47,10 +47,10 @@ parseBooleanLiteral :: P.Parsec String ParseState Value

47parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

49parseArrayLiteral :: P.Parsec String ParseState Value

50−parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))

50+parseArrayLiteral = ArrayLiteral <$> C.squares (parseValue `P.sepBy` (C.indented *> C.comma))

52parseObjectLiteral :: P.Parsec String ParseState Value

53−parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))

53+parseObjectLiteral = ObjectLiteral <$> C.braces (parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))

55parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

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

@@ -75,7 +75,7 @@ parseConstructor :: P.Parsec String ParseState Value

75parseConstructor = Constructor <$> C.properName

77parseCase :: P.Parsec String ParseState Value

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

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

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

81parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)

@@ -92,7 +92,7 @@ parseBlock :: P.Parsec String ParseState Value

92parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)

94parseManyStatements :: P.Parsec String ParseState [Statement]

95−parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement) P.<?> "block"

95+parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"

97parseValueAtom :: P.Parsec String ParseState Value

98parseValueAtom = C.indented *> P.choice (map P.try

@@ -123,13 +123,13 @@ parseValue = do

123 . C.buildPostfixParser postfixTable2

124 $ indexersAndAccessors) P.<?> "expression"

125 where

126− indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

126+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

127 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)

128 , Indexer <$> (C.indented *> C.squares parseValue)

129 , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]

130 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])

131 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

132− , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]

132+ , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]

133 operators user =

134 [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

135 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)

@@ -166,11 +166,14 @@ customOperatorTable fixities =

166 sorted = sortBy (compare `on` (snd . snd)) ops

167 levels = groupBy ((==) `on` (snd . snd)) sorted

168 in

169+ map (map $ \(name, (a, _)) ->

169− flip map levels (map (\(name, (a, _)) -> flip Infix (toAssoc a) $ do

170+ flip Infix (toAssoc a) $

170− C.lexeme $ P.try $ do

171+ C.lexeme $ P.try $ do

171− C.indented

172+ C.indented

172− C.reservedOp name P.<?> "operator"

173+ C.reservedOp name P.<?> "operator"

173− return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]))

174+ return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2])

175+ levels

176+

174

177

175toAssoc :: Associativity -> Assoc

178toAssoc :: Associativity -> Assoc

176toAssoc Infixl = AssocLeft

179toAssoc Infixl = AssocLeft

src/PureScript/Pretty.hsnew file+22

@@ -0,0 +1,22 @@

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

2+--

3+-- Module : PureScript.Pretty

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.Pretty (module P) where

16+

17+import PureScript.CodeGen.Pretty.Kinds as P

18+import PureScript.CodeGen.Pretty.Values as P

19+import PureScript.CodeGen.Pretty.Types as P

20+

21+

22+

src/PureScript/TypeChecker.hs+11−14

@@ -12,19 +12,17 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}

15+{-# LANGUAGE FlexibleInstances #-}

17module PureScript.TypeChecker (

18− module PureScript.TypeChecker.Monad,

18+module T,

19− module PureScript.TypeChecker.Kinds,

20− module PureScript.TypeChecker.Types,

21− typeCheckAll,

19+ typeCheckAll

22) where

20) where

24−import PureScript.TypeChecker.Monad

22+import PureScript.TypeChecker.Monad as T

25−import PureScript.TypeChecker.Kinds

23+import PureScript.TypeChecker.Kinds as T

26−import PureScript.TypeChecker.Types

24+import PureScript.TypeChecker.Types as T

27−import PureScript.TypeChecker.Synonyms

25+import PureScript.TypeChecker.Synonyms as T

29import Data.List

27import Data.List

30import Data.Maybe

28import Data.Maybe

@@ -37,23 +35,22 @@ import PureScript.Names

37import PureScript.Kinds

35import PureScript.Kinds

38import PureScript.Declarations

36import PureScript.Declarations

38+import Control.Monad (forM_)

40import Control.Monad.State

39import Control.Monad.State

41import Control.Monad.Error

40import Control.Monad.Error

43−import qualified Data.Map as M

44−

45typeCheckAll :: [Declaration] -> Check ()

42typeCheckAll :: [Declaration] -> Check ()

46typeCheckAll [] = return ()

43typeCheckAll [] = return ()

47typeCheckAll (DataDeclaration name args dctors : rest) = do

44typeCheckAll (DataDeclaration name args dctors : rest) = do

48 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

45 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

49 env <- getEnv

46 env <- getEnv

50 guardWith (name ++ " is already defined") $ not $ M.member name (types env)

47 guardWith (name ++ " is already defined") $ not $ M.member name (types env)

51− ctorKind <- kindsOf (Just name) args (catMaybes $ map snd dctors)

48+ ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)

52 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }

49 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }

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

50+ forM_ dctors $ \(dctor, maybeTy) ->

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

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

55 env' <- getEnv

52 env' <- getEnv

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

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

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

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

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

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

59 let polyType = PolyType args dctorTy

56 let polyType = PolyType args dctorTy

src/PureScript/TypeChecker/Kinds.hs+10−11

@@ -70,9 +70,9 @@ kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind

70kindsOf name args ts = do

71 tyCon <- fresh

72 nargs <- replicateM (length args) fresh

73− (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts

73+ (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts

74 let extraConstraints =

75− KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) DataDeclOrigin

75+ KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin

76 : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts

77 solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution

78 return $ starIfUnknown $ runKindSolution solution tyCon

@@ -87,23 +87,23 @@ kindConstraintsAll m [] = return ([], [], m)

87kindConstraintsAll m (t:ts) = do

88 (cs, n1, m') <- kindConstraints m t

89 (cs', ns, m'') <- kindConstraintsAll m' ts

90− return ((KindConstraint n1 Star (TypeOrigin t)) : cs ++ cs', n1:ns, m'')

90+ return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')

92kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)

93kindConstraints m a@(Array t) = do

94 me <- fresh

95 (cs, n1, m') <- kindConstraints m t

96− return ((KindConstraint n1 Star (TypeOrigin t)) : (KindConstraint me Star (TypeOrigin a)) : cs, me, m')

96+ return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')

97kindConstraints m o@(Object row) = do

98 me <- fresh

99 (cs, r, m') <- kindConstraintsForRow m row

100− return ((KindConstraint me Star (TypeOrigin o)) : (KindConstraint r Row (RowOrigin row)) : cs, me, m')

100+ return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')

101kindConstraints m f@(Function args ret) = do

102 me <- fresh

103 (cs, ns, m') <- kindConstraintsAll m args

104 (cs', retN, m'') <- kindConstraints m' ret

105− return ((KindConstraint retN Star (TypeOrigin ret)) : (KindConstraint me Star (TypeOrigin f)) : (zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args) ++ cs ++ cs', me, m'')

105+ return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'')

106−kindConstraints m (TypeVar v) = do

106+kindConstraints m (TypeVar v) =

107 case M.lookup v m of

108 Just u -> return ([], u, m)

109 Nothing -> throwError $ "Unbound type variable " ++ v

@@ -114,13 +114,12 @@ kindConstraints m c@(TypeConstructor v) = do

114 Nothing -> case M.lookup v (types env) of

115 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"

116 Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)

117− Just u -> do

118− return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)

117+ Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)

119kindConstraints m a@(TypeApp t1 t2) = do

118kindConstraints m a@(TypeApp t1 t2) = do

120 me <- fresh

119 me <- fresh

121 (cs1, n1, m1) <- kindConstraints m t1

120 (cs1, n1, m1) <- kindConstraints m t1

122 (cs2, n2, m2) <- kindConstraints m1 t2

121 (cs2, n2, m2) <- kindConstraints m1 t2

123− return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a)) : cs1 ++ cs2, me, m2)

122+ return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)

124kindConstraints m t = do

123kindConstraints m t = do

125 me <- fresh

124 me <- fresh

126 return ([KindConstraint me Star (TypeOrigin t)], me, m)

125 return ([KindConstraint me Star (TypeOrigin t)], me, m)

@@ -138,7 +137,7 @@ kindConstraintsForRow m r@(RCons _ ty row) = do

138 me <- fresh

137 me <- fresh

139 (cs1, n1, m1) <- kindConstraints m ty

138 (cs1, n1, m1) <- kindConstraints m ty

140 (cs2, n2, m2) <- kindConstraintsForRow m1 row

139 (cs2, n2, m2) <- kindConstraintsForRow m1 row

141− return ((KindConstraint me Row (RowOrigin r)) : (KindConstraint n1 Star (TypeOrigin ty)) : (KindConstraint n2 Row (RowOrigin r)) : cs1 ++ cs2, me, m2)

140+ return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)

142

141

143solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution

142solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution

144solveKindConstraints [] s = return s

143solveKindConstraints [] s = return s

src/PureScript/TypeChecker/Monad.hs+3−3

@@ -24,7 +24,7 @@ import Control.Applicative

24import Control.Monad.State

25import Control.Monad.Error

27−import Control.Arrow ((***))

27+import Control.Arrow ((***), first, second)

29import qualified Data.Map as M

@@ -48,7 +48,7 @@ getEnv :: Check Environment

48getEnv = fmap fst get

50putEnv :: Environment -> Check ()

51−putEnv env = fmap (const env *** id) get >>= put

51+putEnv env = fmap (first (const env)) get >>= put

53fresh :: Check Int

54fresh = do

@@ -57,7 +57,7 @@ fresh = do

57 return n

59check :: Check a -> Either String (a, Environment)

60−check = fmap (id *** fst) . flip runStateT (emptyEnvironment, 0) . unCheck

60+check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck

62guardWith :: (MonadError e m) => e -> Bool -> m ()

63guardWith _ True = return ()

src/PureScript/TypeChecker/Types.hs+36−36

@@ -42,7 +42,7 @@ import Control.Monad.State

42import Control.Monad.Error

44import Control.Applicative

45−import Control.Arrow (Kleisli(..), (***), (&&&))

45+import Control.Arrow (Kleisli(..), (***), (&&&), first)

46import qualified Control.Category as C

48import qualified Data.Map as M

@@ -105,7 +105,7 @@ allUnknownsBecameQuantified cs solution ty = do

105 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

106

107setify :: Row -> Row

108−setify = rowFromList . (M.toList . M.fromList *** id) . rowToList

108+setify = rowFromList . first (M.toList . M.fromList) . rowToList

109

110setifyAll :: (D.Data d) => d -> d

111setifyAll = everywhere (mkT setify)

@@ -143,7 +143,7 @@ varIfUnknown ty =

143 m <- get

144 case M.lookup n m of

145 Nothing -> do

146− let name = "t" ++ show (M.size m)

146+ let name = 't' : show (M.size m)

147 put $ M.insert n name m

148 return $ TypeVar name

149 Just name -> return $ TypeVar name

@@ -153,7 +153,7 @@ varIfUnknown ty =

153 m <- get

154 case M.lookup n m of

155 Nothing -> do

156− let name = "r" ++ show (M.size m)

156+ let name = 'r' : show (M.size m)

157 put $ M.insert n name m

158 return $ RowVar name

159 Just name -> return $ RowVar name

@@ -198,9 +198,9 @@ replaceAllTypeSynonyms d = do

198 either throwError return $ saturateAllTypeSynonyms syns d

199

200desaturateAllTypeSynonyms :: (D.Data d) => d -> d

201−desaturateAllTypeSynonyms = everywhere (mkT $ replace)

201+desaturateAllTypeSynonyms = everywhere (mkT replace)

202 where

203− replace (SaturatedTypeSynonym name args) = foldl (\t arg -> TypeApp t arg) (TypeConstructor name) args

203+ replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

204 replace t = t

205

206replaceType :: (D.Data d) => Int -> Type -> d -> d

@@ -259,7 +259,7 @@ typeConstraints _ v@(BooleanLiteral _) = do

259 return ([TypeConstraint me Boolean (ValueOrigin v)], me)

260typeConstraints m v@(ArrayLiteral vals) = do

261 all <- mapM (typeConstraints m) vals

262− let (cs, ns) = (concat . map fst &&& map snd) all

262+ let (cs, ns) = (concatMap fst &&& map snd) all

263 me <- fresh

264 return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me)

265typeConstraints m u@(Unary op val) = do

@@ -274,15 +274,15 @@ typeConstraints m b@(Binary op left right) = do

274typeConstraints m v@(ObjectLiteral ps) = do

275 ensureNoDuplicateProperties ps

276 all <- mapM (typeConstraints m . snd) ps

277− let (cs, ns) = (concat . map fst &&& map snd) all

277+ let (cs, ns) = (concatMap fst &&& map snd) all

278 me <- fresh

279 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

280− return ((TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v)) : cs, me)

280+ return (TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v) : cs, me)

281typeConstraints m v@(ObjectUpdate o ps) = do

282 ensureNoDuplicateProperties ps

283 (cs1, n1) <- typeConstraints m o

284 all <- mapM (typeConstraints m . snd) ps

285− let (cs2, ns) = (concat . map fst &&& map snd) all

285+ let (cs2, ns) = (concatMap fst &&& map snd) all

286 row <- fresh

287 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

288 return (TypeConstraint n1 (Object (rowFromList (tys, RUnknown row))) (ValueOrigin v) : cs1 ++ cs2, n1)

@@ -290,24 +290,24 @@ typeConstraints m v@(Indexer index val) = do

290 (cs1, n1) <- typeConstraints m index

291 (cs2, n2) <- typeConstraints m val

292 me <- fresh

293− return ((TypeConstraint n1 Number (ValueOrigin index)) : (TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

293+ return (TypeConstraint n1 Number (ValueOrigin index) : TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)

294typeConstraints m v@(Accessor prop val) = do

295 (cs, n1) <- typeConstraints m val

296 me <- fresh

297 rest <- fresh

298− return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v)) : cs, me)

298+ return (TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v) : cs, me)

299typeConstraints m v@(Abs args ret) = do

300 ns <- replicateM (length args) fresh

301− let m' = m `M.union` M.fromList (zipWith (,) args ns)

301+ let m' = m `M.union` M.fromList (zip args ns)

302 (cs, n') <- typeConstraints m' ret

303 me <- fresh

304− return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v)) : cs, me)

304+ return (TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v) : cs, me)

305typeConstraints m v@(App f xs) = do

306 (cs1, n1) <- typeConstraints m f

307 all <- mapM (typeConstraints m) xs

308− let (cs2, ns) = (concat . map fst &&& map snd) all

308+ let (cs2, ns) = (concatMap fst &&& map snd) all

309 me <- fresh

310− return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

310+ return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)

311typeConstraints m v@(Var var) =

312 case M.lookup var m of

313 Nothing -> do

@@ -381,7 +381,7 @@ equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint]

381equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]

382

383symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint]

384−symBinOpConstraints v ty left right result = asymBinOpConstraints v ty ty left right result

384+symBinOpConstraints v ty = asymBinOpConstraints v ty ty

385

386asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

387asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)]

@@ -408,14 +408,14 @@ typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do

408 obj <- fresh

409 (Function [ty] ret) <- replaceVarsWithUnknowns idents f

410 (cs, m1) <- typeConstraintsForBinder obj binder

411− return ((TypeConstraint val ret (BinderOrigin b)) : (TypeConstraint obj ty (BinderOrigin b)) : cs, m1)

411+ return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)

412 Just _ -> throwError $ ctor ++ " is not a unary constructor"

413 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

414typeConstraintsForBinder val b@(ObjectBinder props) = do

415 row <- fresh

416 rest <- fresh

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

418− return ((TypeConstraint val (Object (RUnknown row)) (BinderOrigin b)) : cs, m1)

418+ return (TypeConstraint val (Object (RUnknown row)) (BinderOrigin b) : cs, m1)

419 where

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

421 typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row (BinderOrigin b)], M.empty)

@@ -423,17 +423,17 @@ typeConstraintsForBinder val b@(ObjectBinder props) = do

423 propTy <- fresh

424 (cs1, m1) <- typeConstraintsForBinder propTy binder

425 (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders

426− return (cs1 ++ cs2, M.union m1 m2)

426+ return (cs1 ++ cs2, m1 `M.union` m2)

427typeConstraintsForBinder val b@(ArrayBinder binders rest) = do

428 el <- fresh

429 all <- mapM (typeConstraintsForBinder el) binders

430− let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all

430+ let (cs1, m1) = (concatMap fst &&& M.unions . map snd) all

431 let arrayConstraint = TypeConstraint val (Array (TUnknown el)) (BinderOrigin b)

432 case rest of

433 Nothing -> return (arrayConstraint : cs1, m1)

434 Just binder -> do

435 (cs2, m2) <- typeConstraintsForBinder val binder

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

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

437typeConstraintsForBinder val b@(NamedBinder name binder) = do

438 me <- fresh

439 (cs, m) <- typeConstraintsForBinder val binder

@@ -450,9 +450,9 @@ typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)]

450typeConstraintsForBinders _ _ _ [] = return []

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

452 (cs1, m1) <- typeConstraintsForBinder nval binder

453− (cs2, n2) <- typeConstraints (M.union m m1) val

453+ (cs2, n2) <- typeConstraints (m `M.union` m1) val

454 cs3 <- typeConstraintsForBinders m nval ret bs

455− return ((TypeConstraint n2 (TUnknown ret) (BinderOrigin binder)) : cs1 ++ cs2 ++ cs3)

455+ return (TypeConstraint n2 (TUnknown ret) (BinderOrigin binder) : cs1 ++ cs2 ++ cs3)

456

457assignVariable :: Ident -> M.Map Ident Int -> Check ()

458assignVariable name m =

@@ -464,27 +464,27 @@ typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Stat

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

465 assignVariable name (m `M.union` mass)

466 (cs1, n1) <- typeConstraints m val

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

467+ return (cs1, False, M.insert name n1 mass)

468typeConstraintsForStatement m mass ret (Assignment ident val) = do

469 (cs1, n1) <- typeConstraints m val

470 case M.lookup ident mass of

471 Nothing -> throwError $ "No local variable with name " ++ show ident

472− Just ty -> do

472+ Just ty ->

473 return (TypeConstraint n1 (TUnknown ty) (AssignmentTargetOrigin ident) : cs1, False, mass)

474typeConstraintsForStatement m mass ret (While val inner) = do

475 (cs1, n1) <- typeConstraints m val

476 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner

477− return $ ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, allCodePathsReturn, mass)

477+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, allCodePathsReturn, mass)

478typeConstraintsForStatement m mass ret (If ifst) = do

479 (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

480− return $ (cs, allCodePathsReturn, mass)

480+ return (cs, allCodePathsReturn, mass)

481typeConstraintsForStatement m mass ret (For ident start end inner) = do

482 assignVariable ident (m `M.union` mass)

483 (cs1, n1) <- typeConstraints (m `M.union` mass) start

484 (cs2, n2) <- typeConstraints (m `M.union` mass) end

485 let mass1 = M.insert ident n1 mass

486 (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

487− return $ ((TypeConstraint n1 Number (ValueOrigin start)) : (TypeConstraint n2 Number (ValueOrigin end)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)

487+ return (TypeConstraint n1 Number (ValueOrigin start) : TypeConstraint n2 Number (ValueOrigin end) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)

488typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

489 assignVariable ident (m `M.union` mass)

490 val <- fresh

@@ -492,21 +492,21 @@ typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

492 let mass1 = M.insert ident val mass

493 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

494 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

495− return $ ((TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals)) : cs1 ++ cs2, False, mass)

495+ return (TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals) : cs1 ++ cs2, False, mass)

496typeConstraintsForStatement m mass ret (Return val) = do

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

498− return ((TypeConstraint n1 (TUnknown ret) (ValueOrigin val)) : cs1, True, mass)

498+ return (TypeConstraint n1 (TUnknown ret) (ValueOrigin val) : cs1, True, mass)

499

500typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)

501typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do

502 (cs1, n1) <- typeConstraints m val

503 (cs2, _, _) <- typeConstraintsForBlock m mass ret thens

504− return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, False)

504+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, False)

505typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do

506 (cs1, n1) <- typeConstraints m val

507 (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens

508 (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses

509− return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)

509+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)

510

511typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)

512typeConstraintsForElseStatement m mass ret (Else elses) = do

@@ -541,7 +541,7 @@ solveTypeConstraints (RowConstraint n r o:cs) s = do

541 (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do

542 rowOccursCheck n r

543 let s' = let (f, g) = runTypeSolution s

544− in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)

544+ in TypeSolution (replaceRow n r . f, replaceRow n r . g)

545 cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs

546 return (cs', s')

547 solveTypeConstraints cs' s'

@@ -603,8 +603,8 @@ unifyRows o r1 r2 =

603 (s1, r1') = rowToList r1

604 (s2, r2') = rowToList r2

605 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

606− sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

606+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

607− sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

607+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

608 in do

609 cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int

610 cs2 <- unifyRows' o sd1 r1' sd2 r2'