cb906fa · rowtype-yoga/purescript-native

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

on golang help sign in

Merge branch 'master' into auto-prelude

cb906faPhil Freeman13 years ago

RELEASE-0.5.md+3

compare with golang

unifiedsplit

@@ -40,6 +40,8 @@

40- Imported type class instances are now exported (paf31)

41- Some error messages were improved (paf31)

42- Qualfied module imports are now supported as `import qualified M as X` (garyb).

43+- The escape check was removed, since it was too restrictive (paf31)

44+- The binary operator reordering step was greatly simplified (paf31)

44### Bug Fixes

46### Bug Fixes

@@ -51,6 +53,7 @@

51- A type checker bug related to array literals was fixed (paf31)

53- A type checker bug related to array literals was fixed (paf31)

52- Externs files (`--externs`) are now working again (paf31)

54- Externs files (`--externs`) are now working again (paf31)

53- Precedence of backticked infix functions have been corrected (paf31)

55- Precedence of backticked infix functions have been corrected (paf31)

56+- A bug which allowed some incorrect type class instances to pass the type checker was fixed (paf31)

55### Libraries

58### Libraries

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

@@ -328,7 +328,7 @@ buildPostfixParser fs first = do

328-- Parse an identifier in backticks or an operator

329--

330parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

331−parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator)

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

332

333-- |

334-- Mark the current indentation level

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

@@ -49,11 +49,11 @@ import Language.PureScript.Sugar.Names as S

49-- * Qualify any unqualified names and types

50--

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

52−desugar = rebracket

53− >=> desugarDo

52+desugar = desugarDo

54 >=> desugarLetBindings

53 >=> desugarLetBindings

55 >>> desugarCasesModule

54 >>> desugarCasesModule

56 >=> desugarImports

55 >=> desugarImports

56+ >=> rebracket

57 >=> desugarTypeDeclarationsModule

58 >=> desugarTypeClasses

59 >=> createBindingGroupsModule

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

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

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

191 where

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

193− bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')

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

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

194− bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')

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

196+ (,) bound <$> (Var <$> updateValueName name')

197+ bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =

198+ (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)

199+ bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

200+ (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)

195 bindFunctionArgs bound other = return (bound, other)

201 bindFunctionArgs bound other = return (bound, other)

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

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

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

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

src/Language/PureScript/Sugar/Operators.hs+40−46

@@ -28,15 +28,15 @@ import Language.PureScript.Declarations

28import Language.PureScript.Values

30import Control.Applicative

31−import Control.Arrow (first)

32import Control.Monad.State

31import Control.Monad.State

32+import Control.Monad.Error.Class

34import Data.Maybe (fromMaybe, mapMaybe)

35import Data.Function (on)

36import Data.Functor.Identity

37−import Data.List (groupBy, sortBy)

37+import Data.List (sort, groupBy, sortBy)

39−import qualified Data.Map as M

39+import qualified Data.Data as D

40import qualified Data.Generics as G

41import qualified Data.Generics.Extras as G

@@ -48,28 +48,41 @@ import qualified Text.Parsec.Expr as P

48-- Remove explicit parentheses and reorder binary operator applications

49--

50rebracket :: [Module] -> Either String [Module]

51−rebracket = go M.empty []

51+rebracket ms = do

52+ let fixities = concatMap collectFixities ms

53+ ensureNoDuplicates $ map fst fixities

54+ let opTable = customOperatorTable fixities

55+ mapM (rebracketModule opTable) ms

56+

57+rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module

58+rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts

59+

60+removeParens :: (D.Data d) => d -> d

61+removeParens = G.everywhere (G.mkT go)

62+ where

63+ go (Parens val) = val

64+ go val = val

65+

66+collectFixities :: Module -> [(Qualified Ident, Fixity)]

67+collectFixities (Module moduleName ds _) = concatMap collect ds

68+ where

69+ collect :: Declaration -> [(Qualified Ident, Fixity)]

70+ collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

71+ collect _ = []

72+

73+ensureNoDuplicates :: [Qualified Ident] -> Either String ()

74+ensureNoDuplicates m = go $ sort m

52 where

75 where

53− go _ rb [] = return . reverse $ rb

76+ go [] = return ()

54− go m rb (Module name ds exps : ms) = do

77+ go [_] = return ()

55− m' <- M.union m <$> collectFixities m name ds

78+ go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x

56− let opTable = customOperatorTable m'

79+ go (_ : rest) = go rest

57− ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds

80+

58− go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms

59−

60−removeParens :: Value -> Value

61−removeParens (Parens val) = val

62−removeParens val = val

63−

64−customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

81+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

65customOperatorTable fixities =

82customOperatorTable fixities =

66 let

83 let

67− -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.

68− -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name

69− -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to

70− -- make sure that the generated code is correct.

71− applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)

84+ applyUserOp ident t1 = App (App (Var ident) t1)

72− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

85+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities

73 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps

86 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps

74 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

87 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

75 in

88 in

@@ -77,8 +90,8 @@ customOperatorTable fixities =

78type Chain = [Either Value (Qualified Ident)]

91type Chain = [Either Value (Qualified Ident)]

80−matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

93+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

81−matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)

94+matchOperators ops = parseChains

82 where

95 where

83 parseChains :: Value -> Either String Value

96 parseChains :: Value -> Either String Value

84 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

97 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

@@ -89,7 +102,7 @@ matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)

89 bracketChain :: Chain -> Either String Value

102 bracketChain :: Chain -> Either String Value

90 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

103 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

91 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

104 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

92− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops

105+ : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

93 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

106 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

107

95toAssoc :: Associativity -> P.Assoc

108toAssoc :: Associativity -> P.Assoc

@@ -114,27 +127,8 @@ parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"

114 fromOp q@(Qualified _ (Ident _)) = Just q

127 fromOp q@(Qualified _ (Ident _)) = Just q

115 fromOp _ = Nothing

128 fromOp _ = Nothing

116

129

117−matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()

130+matchOp :: Qualified Ident -> P.Parsec Chain () ()

118−matchOp moduleName op = do

131+matchOp op = do

119 ident <- parseOp

132 ident <- parseOp

120 guard (qualify moduleName ident == qualify moduleName op)

133 guard (qualify moduleName ident == qualify moduleName op)

121

134

122−collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

123−collectFixities m _ [] = return m

124−collectFixities m moduleName (FixityDeclaration fixity name : rest) = do

125− let qual = Qualified (Just moduleName) (Op name)

126− when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)

127− collectFixities (M.insert qual fixity m) moduleName rest

128−collectFixities m moduleName (ImportDeclaration importedModule explImports qual : rest) = do

129− let qualName = fromMaybe moduleName qual

130− let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule && isImported explImports i ]

131− let m' = M.fromList (map (first (Qualified (Just qualName))) fs)

132− collectFixities (m' `M.union` m) moduleName rest

133− where

134− isImported Nothing _ = True

135− isImported (Just imps) i = i `elem` (mapMaybe getExportedValue imps)

136− getExportedValue (ValueRef name) = Just name

137− getExportedValue _ = Nothing

138−

139−collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

140−

src/Language/PureScript/TypeChecker.hs+3−2

@@ -36,6 +36,7 @@ import Language.PureScript.Values

36import Language.PureScript.Kinds

37import Language.PureScript.Declarations

38import Language.PureScript.Environment

39+import Language.PureScript.Pretty.Types

40addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

41addDataType moduleName name args dctors ctorKind = do

42addDataType moduleName name args dctors ctorKind = do

@@ -86,8 +87,8 @@ checkTypeClassInstance _ (TypeConstructor ctor) = do

86 env <- getEnv

87 env <- getEnv

87 when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

88 when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

88 return ()

89 return ()

89−checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty

90+checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

90−checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"

91+checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty

92-- |

93-- |

93-- Type check all declarations in a module

94-- Type check all declarations in a module

src/Language/PureScript/TypeChecker/Types.hs+39−15

@@ -246,21 +246,22 @@ overTypes f = everywhere (mkT f)

246replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

247replaceTypeClassDictionaries mn = everywhereM' (mkM go)

248 where

249− go (TypeClassDictionary constraint dicts) = entails mn dicts constraint

249+ go (TypeClassDictionary constraint dicts) = do

250+ env <- getEnv

251+ entails env mn dicts constraint

250 go other = return other

252 go other = return other

251

253

252-- |

254-- |

253-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

255-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

254-- return a type class dictionary reference.

256-- return a type class dictionary reference.

255--

257--

256−entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

258+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

257−entails moduleName context goal@(className, tys) = do

259+entails env moduleName context goal@(className, tys) = do

258− env <- getEnv

259− case go env goal of

260+ case go goal of

260 [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

261 [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

261 (dict : _) -> return dict

262 (dict : _) -> return dict

262 where

263 where

263− go env (className', tys') =

264+ go (className', tys') =

264 [ mkDictionary (canonicalizeDictionary tcd) args

265 [ mkDictionary (canonicalizeDictionary tcd) args

265 | tcd <- context

266 | tcd <- context

266 -- Choose type class dictionaries in scope in the current module

267 -- Choose type class dictionaries in scope in the current module

@@ -270,14 +271,14 @@ entails moduleName context goal@(className, tys) = do

270 -- Make sure the type unifies with the type in the type instance definition

271 -- Make sure the type unifies with the type in the type instance definition

271 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

272 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

272 -- Solve any necessary subgoals

273 -- Solve any necessary subgoals

273− , args <- solveSubgoals env subst (tcdDependencies tcd) ]

274+ , args <- solveSubgoals subst (tcdDependencies tcd) ]

274 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

275 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

275 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

276 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

276 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

277 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

277− solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]

278+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]

278− solveSubgoals _ _ Nothing = return Nothing

279+ solveSubgoals _ Nothing = return Nothing

279− solveSubgoals env subst (Just subgoals) = do

280+ solveSubgoals subst (Just subgoals) = do

280− dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals

281+ dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals

281 return $ Just dict

282 return $ Just dict

282 -- Make a dictionary from subgoal dictionaries by applying the correct function

283 -- Make a dictionary from subgoal dictionaries by applying the correct function

283 mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

284 mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

@@ -293,20 +294,43 @@ entails moduleName context goal@(className, tys) = do

293 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

294 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

294 verifySubstitution subst = do

295 verifySubstitution subst = do

295 let grps = groupBy ((==) `on` fst) subst

296 let grps = groupBy ((==) `on` fst) subst

296− guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps)

297+ guard (all (pairwise (unifiesWith env) . map snd) grps)

297 return $ map head grps

298 return $ map head grps

298

299

300+-- |

301+-- Check all values in a list pairwise match a predicate

302+--

303+pairwise :: (a -> a -> Bool) -> [a] -> Bool

304+pairwise _ [] = True

305+pairwise _ [_] = True

306+pairwise p (x : xs) = all (p x) xs && pairwise p xs

307+

308+-- |

309+-- Check that two types unify

310+--

311+unifiesWith :: Environment -> Type -> Type -> Bool

312+unifiesWith _ (TUnknown _) _ = True

313+unifiesWith _ _ (TUnknown _) = True

314+unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True

315+unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True

316+unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

317+unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2

318+unifiesWith e (SaturatedTypeSynonym name args) t2 =

319+ case expandTypeSynonym' e name args of

320+ Left _ -> False

321+ Right t1 -> unifiesWith e t1 t2

322+unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1

323+unifiesWith _ _ _ = False

324+

299-- |

325-- |

300-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),

326-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),

301-- and return a substitution from type variables to types which makes the type heads unify.

327-- and return a substitution from type variables to types which makes the type heads unify.

302--

328--

303typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

329typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

304typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

330typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

305−typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]

306typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

331typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

307typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

332typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

308−typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

333+typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2

309−typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

310typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

334typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

311 Left _ -> Nothing

335 Left _ -> Nothing

312 Right t1 -> typeHeadsAreEqual m e t1 t2

336 Right t1 -> typeHeadsAreEqual m e t1 t2