2541264 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge master

2541264Phil Freeman11 years ago

examples/passing/TypedBinders.purs+6−1

compare with golang

unifiedsplit

@@ -54,9 +54,14 @@ test3 n = case n of

54test4 :: Tuple Int Int -> Tuple Int Int

55test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a)

57+type Int1 = Int

58+

59+test5 :: Int1 -> Int1

60+test5 = \(x :: Int1) -> x

61+

57main = do

62main = do

58 let t1 = test

63 let t1 = test

59 t2 = test2 id

64 t2 = test2 id

60 t3 = test3 1

65 t3 = test3 1

61 t4 = test4 (Tuple 1 0)

66 t4 = test4 (Tuple 1 0)

62− Control.Monad.Eff.Console.log "Done"

67+ Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/Errors.hs+4−4

@@ -137,7 +137,7 @@ data SimpleErrorMessage

137 | ShadowedTypeVar String

138 | UnusedTypeVar String

139 | WildcardInferredType Type

140− | MissingTypeDeclaration Ident

140+ | MissingTypeDeclaration Ident Type

141 | NotExhaustivePattern [[Binder]] Bool

142 | OverlappingPattern [[Binder]] Bool

143 | IncompleteExhaustivityCheck

@@ -671,11 +671,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

671 paras [ line "Wildcard type definition has the inferred type "

672 , indent $ typeAsBox ty

673 ]

674− renderSimpleErrorMessage (MissingTypeDeclaration ident) =

674+ renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

675 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."

676 , line "It is good practice to provide type declarations as a form of documentation."

677− , line "Consider using a type wildcard to display the inferred type:"

677+ , line $ "The inferred type of " ++ showIdent ident ++ " was:"

678− , indent $ line $ showIdent ident ++ " :: _"

678+ , indent $ typeAsBox ty

679 ]

680 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

681 paras $ [ line "A case expression could not be determined to cover all inputs."

src/Language/PureScript/Pretty/Types.hs+10−4

@@ -46,14 +46,13 @@ typeLiterals = mkPattern match

46 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

47 match (TUnknown u) = Just $ text $ '_' : show u

48 match (Skolem name s _) = Just $ text $ name ++ show s

49− match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty

50 match REmpty = Just $ text "()"

49 match REmpty = Just $ text "()"

51 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

50 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

52 match _ = Nothing

51 match _ = Nothing

54−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box

53+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

55−constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty

54+constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

56−constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty)

55+constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

58constraintAsBox :: Qualified ProperName -> [Type] -> Box

57constraintAsBox :: Qualified ProperName -> [Type] -> Box

59constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

58constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

@@ -115,6 +114,12 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes

115 go idents other = PrettyPrintForAll idents other

114 go idents other = PrettyPrintForAll idents other

116 convertForAlls other = other

115 convertForAlls other = other

117

116

117+constrained :: Pattern () Type ([Constraint], Type)

118+constrained = mkPattern match

119+ where

120+ match (ConstrainedType deps ty) = Just (deps, ty)

121+ match _ = Nothing

122+

118matchTypeAtom :: Pattern () Type Box

123matchTypeAtom :: Pattern () Type Box

119matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

124matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType

120

125

@@ -126,6 +131,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

126 OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

131 OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]

127 , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

132 , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)

128 ]

133 ]

134+ , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

129 , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

135 , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]

130 , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]

136 , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]

131 ]

137 ]

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−20

@@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations (

25#if __GLASGOW_HASKELL__ < 710

26import Control.Applicative

27#endif

28−import Control.Monad (forM, when)

28+import Control.Monad (forM)

29import Control.Monad.Error.Class (MonadError(..))

30−import Control.Monad.Writer.Class (MonadWriter(tell))

32import Language.PureScript.Crash

31import Language.PureScript.Crash

33import Language.PureScript.AST

32import Language.PureScript.AST

@@ -39,19 +38,19 @@ import Language.PureScript.Traversals

39-- |

38-- |

40-- Replace all top level type declarations in a module with type annotations

39-- Replace all top level type declarations in a module with type annotations

41--

40--

42−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

41+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

43desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

42desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

44 rethrow (addHint (ErrorInModule name)) $

43 rethrow (addHint (ErrorInModule name)) $

45− Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps

44+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

46 where

45 where

48− desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

47+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]

49− desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do

48+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

50− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)

49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

51 return (PositionedDeclaration pos com d' : ds')

50 return (PositionedDeclaration pos com d' : ds')

52− desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do

51+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

53 (_, nameKind, val) <- fromValueDeclaration d

52 (_, nameKind, val) <- fromValueDeclaration d

54− desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

53+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

55 where

54 where

56 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

55 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

57 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

56 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

@@ -59,19 +58,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

59 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

58 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

60 return (ident, nameKind, PositionedValue pos com val)

59 return (ident, nameKind, PositionedValue pos com val)

61 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

60 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

62− desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

61+ desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

63− desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do

62+ desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

64− -- At the top level, match a type signature or emit a warning.

65− when reqd $ case val of

66− Right TypedValue{} -> return ()

67− Left _ -> internalError "desugarTypeDeclarations: cases were not desugared"

68− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

69 let (_, f, _) = everywhereOnValuesTopDownM return go return

63 let (_, f, _) = everywhereOnValuesTopDownM return go return

70 f' (Left gs) = Left <$> mapM (pairM return f) gs

64 f' (Left gs) = Left <$> mapM (pairM return f) gs

71 f' (Right v) = Right <$> f v

65 f' (Right v) = Right <$> f v

72− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest

66+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

73 where

67 where

74− go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'

68+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

75 go other = return other

69 go other = return other

76− desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

70+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

77− desugarTypeDeclarations _ [] = return []

71+ desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker/Types.hs+6−1

@@ -50,6 +50,7 @@ import Control.Monad

50import Control.Monad.State

51import Control.Monad.Unify

52import Control.Monad.Error.Class (MonadError(..))

53+import Control.Monad.Writer.Class (tell)

54import Language.PureScript.Crash

55import Language.PureScript.Crash

55import Language.PureScript.AST

56import Language.PureScript.AST

@@ -94,6 +95,7 @@ typesOf moduleName vals = do

94 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

95 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

95 -- Replace all the wildcards types with their inferred types

96 -- Replace all the wildcards types with their inferred types

96 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

97 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)

98+ replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty))

97 replace _ em = em

99 replace _ em = em

100

99type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

101type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -140,6 +142,7 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do

140 -- Infer the type with the new names in scope

142 -- Infer the type with the new names in scope

141 TypedValue _ val' ty <- bindNames dict $ infer val

143 TypedValue _ val' ty <- bindNames dict $ infer val

142 ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

144 ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

145+ tell . errorMessage $ MissingTypeDeclaration ident ty

143 return (ident, (TypedValue True val' ty, ty))

146 return (ident, (TypedValue True val' ty, ty))

144

147

145-- |

148-- |

@@ -373,7 +376,9 @@ inferBinder val (PositionedBinder pos _ binder) =

373 warnAndRethrowWithPosition pos $ inferBinder val binder

376 warnAndRethrowWithPosition pos $ inferBinder val binder

374-- TODO: When adding support for polymorphic types, check subsumption here

377-- TODO: When adding support for polymorphic types, check subsumption here

375-- and change the definition of `binderRequiresMonotype`

378-- and change the definition of `binderRequiresMonotype`

376−inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder

379+inferBinder val (TypedBinder ty binder) = do

380+ ty' <- replaceAllTypeSynonyms ty

381+ val =?= ty' >> inferBinder val binder

377

382

378-- | Returns true if a binder requires its argument type to be a monotype.

383-- | Returns true if a binder requires its argument type to be a monotype.

379-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

384-- | If this is the case, we need to instantiate any polymorphic types before checking binders.