6d3a777 · rowtype-yoga/purescript-native

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

on golang help sign in

Modified the TypeChecker monad for supporting warnings.

6d3a777Nicolas Del Piano11 years ago

examples/manual/passing/ShadowedName.pursnew file+10

compare with golang

unifiedsplit

@@ -0,0 +1,10 @@

1+module Main where

3+import Prelude

4+import Debug.Trace

6+done :: String

7+done = let str = "Not yet done" in

8+ let str = "Done" in str

10+main = Debug.Trace.trace done

examples/manual/passing/WildcardType.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+import Prelude

4+import Debug.Trace

6+f1 :: (_ -> _) -> _

7+f1 g = g 1

9+f2 :: _ -> _

10+f2 _ = "Done"

11+

12+main = Debug.Trace.trace $ f1 f2

13+

psci/PSCi.hs+2−2

@@ -33,7 +33,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)

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

34import Control.Monad.Trans.Except (ExceptT(..), runExceptT)

35import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

36−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)

36+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, runWriter)

37import Control.Monad.Trans.Class

38import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

39import Control.Monad.Trans.State.Strict

@@ -439,7 +439,7 @@ handleKindOf typ = do

439 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

440 Just (_, typ') -> do

441 let chk = P.CheckState env' 0 0 (Just mName)

442− k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk

442+ k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf mName typ')) chk

443 case k of

444 Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

445 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

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

@@ -27,8 +27,9 @@ import Data.Foldable (fold, foldMap)

27import qualified Data.Map as M

29import Control.Monad

30−import Control.Monad.Error.Class (MonadError(..))

31import Control.Monad.Unify

30import Control.Monad.Unify

31+import Control.Monad.Writer

32+import Control.Monad.Error.Class (MonadError(..))

32import Control.Applicative ((<$>), (<*>), Applicative, pure)

33import Control.Applicative ((<$>), (<*>), Applicative, pure)

33import Control.Monad.Trans.State.Lazy

34import Control.Monad.Trans.State.Lazy

34import Control.Arrow(first)

35import Control.Arrow(first)

@@ -113,6 +114,7 @@ data SimpleErrorMessage

113 | InvalidInstanceHead Type

114 | InvalidInstanceHead Type

114 | TransitiveExportError DeclarationRef [DeclarationRef]

115 | TransitiveExportError DeclarationRef [DeclarationRef]

115 | ShadowedName Ident

116 | ShadowedName Ident

117+ | WildcardInferredType Type

116 | PreludeNotPresent

118 | PreludeNotPresent

117 deriving (Show)

119 deriving (Show)

118

120

@@ -216,6 +218,7 @@ errorCode em = case unwrapErrorMessage em of

216 (InvalidInstanceHead _) -> "InvalidInstanceHead"

218 (InvalidInstanceHead _) -> "InvalidInstanceHead"

217 (TransitiveExportError _ _) -> "TransitiveExportError"

219 (TransitiveExportError _ _) -> "TransitiveExportError"

218 (ShadowedName _) -> "ShadowedName"

220 (ShadowedName _) -> "ShadowedName"

221+ (WildcardInferredType _) -> "WildcardInferredType"

219 PreludeNotPresent -> "PreludeNotPresent"

222 PreludeNotPresent -> "PreludeNotPresent"

220

223

221-- |

224-- |

@@ -458,6 +461,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

458 goSimple (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

461 goSimple (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

459 : map (line . prettyPrintExport) ys

462 : map (line . prettyPrintExport) ys

460 goSimple (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."

463 goSimple (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."

464+ goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

461 goSimple PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."

465 goSimple PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."

462 , line $ "You probably need to install the Prelude and other dependencies using Bower."

466 , line $ "You probably need to install the Prelude and other dependencies using Bower."

463 ]

467 ]

@@ -638,10 +642,12 @@ renderBox = unlines . map trimEnd . lines . Box.render

638 trimEnd = reverse . dropWhile (== ' ') . reverse

642 trimEnd = reverse . dropWhile (== ' ') . reverse

639

643

640-- |

644-- |

641−-- Interpret multiple errors in a monad supporting errors

645+-- Interpret multiple errors and warnings in a monad supporting errors and warnings

642--

646--

643−interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a

647+interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a

648+interpretMultipleErrorsAndWarnings (err, ws) = do

649+ tell ws

644−interpretMultipleErrors = either throwError return

650+ either throwError return $ err

645

651

646-- |

652-- |

647-- Rethrow an error with a more detailed error message in the case of failure

653-- Rethrow an error with a more detailed error message in the case of failure

src/Language/PureScript/TypeChecker/Monad.hs+33−11

@@ -22,9 +22,11 @@ import Data.Maybe

22import qualified Data.Map as M

24import Control.Applicative

25−import Control.Monad.Error.Class (MonadError(..))

26import Control.Monad.State

25import Control.Monad.State

27import Control.Monad.Unify

26import Control.Monad.Unify

27+import Control.Monad.Writer

28+import Control.Monad.Error.Class (MonadError(..))

29+import Control.Monad.Trans.Except

29import Language.PureScript.Environment

31import Language.PureScript.Environment

30import Language.PureScript.Errors

32import Language.PureScript.Errors

@@ -176,8 +178,8 @@ data CheckState = CheckState {

176-- |

178-- |

177-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

179-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

178--

180--

179−newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }

181+newtype Check a = Check { unCheck :: StateT CheckState (ExceptT MultipleErrors (Writer MultipleErrors)) a }

180− deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)

182+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors, MonadWriter MultipleErrors)

181

183

182-- |

184-- |

183-- Get the current @Environment@

185-- Get the current @Environment@

@@ -200,16 +202,26 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

200-- |

202-- |

201-- Run a computation in the Check monad, starting with an empty @Environment@

203-- Run a computation in the Check monad, starting with an empty @Environment@

202--

204--

203−runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment)

205+runCheck :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Check a -> m (a, Environment)

204runCheck = runCheck' initEnvironment

206runCheck = runCheck' initEnvironment

205

207

206-- |

208-- |

207-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

209-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

208--

210--

209−runCheck' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment)

211+runCheck' :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Environment -> Check a -> m (a, Environment)

210−runCheck' env c = interpretMultipleErrors $ do

212+runCheck' env = interpretMultipleErrorsAndWarnings . unwrapCheckWithWarnings env

213+ where

214+ unwrapCheckWithWarnings :: Environment -> Check a -> (Either MultipleErrors (a, Environment), MultipleErrors)

215+ unwrapCheckWithWarnings e =

216+ (\(rc, w) -> (envCheck rc, w))

217+ . runWriter

218+ . runExceptT

211− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

219+ . flip runStateT (CheckState e 0 0 Nothing)

220+ . unCheck

221+ envCheck :: Either MultipleErrors (a, CheckState) -> Either MultipleErrors (a, Environment)

222+ envCheck rc = do

223+ (a, s) <- rc

212− return (a, checkEnv s)

224+ return (a, checkEnv s)

213

225

214-- |

226-- |

215-- Make an assertion, failing with an error message

227-- Make an assertion, failing with an error message

@@ -237,8 +249,18 @@ liftCheck = UnifyT . lift

237-- Run a computation in the substitution monad, generating a return value and the final substitution.

249-- Run a computation in the substitution monad, generating a return value and the final substitution.

238--

250--

239liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)

251liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)

240−liftUnify unify = do

252+liftUnify = liftUnifyWarnings (const id)

253+

254+-- |

255+-- Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.

256+--

257+liftUnifyWarnings :: (Partial t) => (Substitution t -> ErrorMessage -> ErrorMessage) -> UnifyT t Check a -> Check (a, Substitution t)

258+liftUnifyWarnings replace unify = do

241 st <- get

259 st <- get

242− (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

260+ let ru = runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

261+ ((a, ust), w) <- censor (const mempty) . listen $ ru

243 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

262 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

244− return (a, unifyCurrentSubstitution ust)

263+ let uust = unifyCurrentSubstitution ust

264+ tell $ onErrorMessages (replace uust) w

265+ return (a, uust)

266+

src/Language/PureScript/TypeChecker/Types.hs+5−2

@@ -42,9 +42,9 @@ import qualified Data.Map as M

43import Control.Applicative

44import Control.Monad

45−import Control.Monad.Error.Class (MonadError(..))

46import Control.Monad.State

45import Control.Monad.State

47import Control.Monad.Unify

46import Control.Monad.Unify

47+import Control.Monad.Error.Class (MonadError(..))

49import Language.PureScript.AST

50import Language.PureScript.Environment

@@ -70,7 +70,7 @@ import qualified Language.PureScript.Constants as C

70--

71typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

72typesOf mainModuleName moduleName vals = do

73− tys <- fmap tidyUp . liftUnify $ do

73+ tys <- fmap tidyUp . liftUnifyWarnings replace $ do

74 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

75 ds1 <- parU typed $ \e -> do

76 triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict

@@ -97,6 +97,9 @@ typesOf mainModuleName moduleName vals = do

97 where

98 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

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

100+ -- Replace all the wildcards types with their inferred types

101+ replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty)

102+ replace _ em = em

100 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

103 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

101 checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do

104 checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do

102 [eff, a] <- replicateM 2 fresh

105 [eff, a] <- replicateM 2 fresh

src/Language/PureScript/TypeChecker/Unify.hs+3−1

@@ -30,8 +30,9 @@ import Data.Maybe (fromMaybe)

30import qualified Data.HashMap.Strict as H

32import Control.Monad

33−import Control.Monad.Error.Class (MonadError(..))

34import Control.Monad.Unify

33import Control.Monad.Unify

34+import Control.Monad.Writer

35+import Control.Monad.Error.Class (MonadError(..))

36import Language.PureScript.Environment

37import Language.PureScript.Environment

37import Language.PureScript.Errors

38import Language.PureScript.Errors

@@ -187,6 +188,7 @@ replaceTypeWildcards = everywhereOnTypesM replace

187 where

188 where

188 replace TypeWildcard = do

189 replace TypeWildcard = do

189 u <- fresh'

190 u <- fresh'

191+ liftCheck . tell $ errorMessage . WildcardInferredType $ TUnknown u

190 return $ TUnknown u

192 return $ TUnknown u

191 replace other = return other

193 replace other = return other

192

194