@@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations (
2525#if __GLASGOW_HASKELL__ < 710
2626import Control.Applicative
2727#endif
28−import Control.Monad (forM, when)
28+import Control.Monad (forM)
2929import Control.Monad.Error.Class (MonadError(..))
30−import Control.Monad.Writer.Class (MonadWriter(tell))
3130
3231import Language.PureScript.AST
3332import Language.PureScript.Names
@@ -38,19 +37,19 @@ import Language.PureScript.Traversals
3837-- |
3938-- Replace all top level type declarations in a module with type annotations
4039--
41−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
40+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
4241desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
4342 rethrow (addHint (ErrorInModule name)) $
44− Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps
43+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
4544 where
4645
47− desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]
48− desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do
49− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)
46+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]
47+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
48+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
5049 return (PositionedDeclaration pos com d' : ds')
51− desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do
50+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
5251 (_, nameKind, val) <- fromValueDeclaration d
53− desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
52+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
5453 where
5554 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
5655 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
@@ -58,19 +57,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
5857 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
5958 return (ident, nameKind, PositionedValue pos com val)
6059 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration 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)
60+ desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
61+ desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
6862 let (_, f, _) = everywhereOnValuesTopDownM return go return
6963 f' (Left gs) = Left <$> mapM (pairM return f) gs
7064 f' (Right v) = Right <$> f v
71− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest
65+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
7266 where
73− go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'
67+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
7468 go other = return other
75− desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds
76− desugarTypeDeclarations _ [] = return []
69+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
70+ desugarTypeDeclarations [] = return []