6d3a777 · rowtype-yoga/purescript-native

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

Modified the TypeChecker monad for supporting warnings.

* Wildcard types are now detected as warnings * Added some manual tests Changed some imports.

commit6d3a777baeb10040b642787a465af4e37ec67294 authorNicolas Del Piano <ndel314@gmail.com> dateWed 6 May 2015, 00:20 (11 years ago) parentd54416a

7 files changed+76−20

compare with golang

unifiedsplit

examples/manual/passing/ShadowedName.purs+10 examples/manual/passing/WildcardType.purs+13 psci/PSCi.hs+2−2 src/Language/PureScript/Errors.hs+10−4 src/Language/PureScript/TypeChecker/Monad.hs+33−11 src/Language/PureScript/TypeChecker/Types.hs+5−2 src/Language/PureScript/TypeChecker/Unify.hs+3−1

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

@@ -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)

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

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

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

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

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

3737import Control.Monad.Trans.Class

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

3939import Control.Monad.Trans.State.Strict

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

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

440440 Just (_, typ') -> do

441441 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

443443 case k of

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

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

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

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

2727import qualified Data.Map as M

2828

2929import Control.Monad

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

3130import Control.Monad.Unify

31+import Control.Monad.Writer

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

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

3334import Control.Monad.Trans.State.Lazy

3435import Control.Arrow(first)

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

113114 | InvalidInstanceHead Type

114115 | TransitiveExportError DeclarationRef [DeclarationRef]

115116 | ShadowedName Ident

117+ | WildcardInferredType Type

116118 | PreludeNotPresent

117119 deriving (Show)

118120

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

216218 (InvalidInstanceHead _) -> "InvalidInstanceHead"

217219 (TransitiveExportError _ _) -> "TransitiveExportError"

218220 (ShadowedName _) -> "ShadowedName"

221+ (WildcardInferredType _) -> "WildcardInferredType"

219222 PreludeNotPresent -> "PreludeNotPresent"

220223

221224-- |

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

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

459462 : map (line . prettyPrintExport) ys

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

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

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

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

463467 ]

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

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

639643

640644-- |

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

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

642646--

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

644−interpretMultipleErrors = either throwError return

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

648+interpretMultipleErrorsAndWarnings (err, ws) = do

649+ tell ws

650+ either throwError return $ err

645651

646652-- |

647653-- 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

2222import qualified Data.Map as M

2323

2424import Control.Applicative

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

2625import Control.Monad.State

2726import Control.Monad.Unify

27+import Control.Monad.Writer

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

29+import Control.Monad.Trans.Except

2830

2931import Language.PureScript.Environment

3032import Language.PureScript.Errors

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

176178-- |

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

178180--

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

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

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

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

181183

182184-- |

183185-- Get the current @Environment@

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

200202-- |

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

202204--

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

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

204206runCheck = runCheck' initEnvironment

205207

206208-- |

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

208210--

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

210−runCheck' env c = interpretMultipleErrors $ do

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

212− return (a, checkEnv s)

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

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

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

224+ return (a, checkEnv s)

213225

214226-- |

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

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

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

238250--

239251liftUnify :: (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

241259 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

243262 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

4242

4343import Control.Applicative

4444import Control.Monad

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

4645import Control.Monad.State

4746import Control.Monad.Unify

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

4848

4949import Language.PureScript.AST

5050import Language.PureScript.Environment

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

7070--

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

7272typesOf mainModuleName moduleName vals = do

73− tys <- fmap tidyUp . liftUnify $ do

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

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

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

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

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

9797 where

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

9999 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

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

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

102105 [eff, a] <- replicateM 2 fresh

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

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

3030import qualified Data.HashMap.Strict as H

3131

3232import Control.Monad

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

3433import Control.Monad.Unify

34+import Control.Monad.Writer

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

3536

3637import Language.PureScript.Environment

3738import Language.PureScript.Errors

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

187188 where

188189 replace TypeWildcard = do

189190 u <- fresh'

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

190192 return $ TUnknown u

191193 replace other = return other

192194