@@ -25,7 +25,7 @@ module Language.PureScript.Sugar.TypeDeclarations (
2525#if __GLASGOW_HASKELL__ < 710
2626import Control.Applicative
2727#endif
28−import Control.Monad (forM)
28+import Control.Monad (forM, when)
2929import Control.Monad.Error.Class (MonadError(..))
3030import Control.Monad.Writer.Class (MonadWriter(tell))
3131
@@ -41,16 +41,16 @@ import Language.PureScript.Traversals
4141desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
4242desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
4343 rethrow (addHint (ErrorInModule name)) $
44− Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
44+ Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps
4545 where
4646
47− desugarTypeDeclarations :: [Declaration] -> m [Declaration]
48− desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
49− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
47+ desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]
48+ desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do
49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)
5050 return (PositionedDeclaration pos com d' : ds')
51− desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
51+ desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do
5252 (_, nameKind, val) <- fromValueDeclaration d
53− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
53+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
5454 where
5555 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
5656 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
@@ -58,18 +58,19 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
5858 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
5959 return (ident, nameKind, PositionedValue pos com val)
6060 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
61− desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
62− desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
63− case val of
64− Right TypedValue{} -> return ()
65− Left _ -> error "desugarTypeDeclarations: cases were not desugared"
66− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)
61+ desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
62+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do
63+ -- At the top level, match a type signature or emit a warning.
64+ when reqd $ case val of
65+ Right TypedValue{} -> return ()
66+ Left _ -> error "desugarTypeDeclarations: cases were not desugared"
67+ _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)
6768 let (_, f, _) = everywhereOnValuesTopDownM return go return
6869 f' (Left gs) = Left <$> mapM (pairM return f) gs
6970 f' (Right v) = Right <$> f v
70− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
71+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest
7172 where
72− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
73+ go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'
7374 go other = return other
74− desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
75− desugarTypeDeclarations [] = return []
75+ desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds
76+ desugarTypeDeclarations _ [] = return []