@@ -15,10 +15,10 @@
1515-----------------------------------------------------------------------------
1616
1717{-# LANGUAGE FlexibleContexts #-}
18+{-# LANGUAGE ScopedTypeVariables #-}
1819{-# LANGUAGE CPP #-}
1920
2021module Language.PureScript.Sugar.TypeDeclarations (
21− desugarTypeDeclarations,
2222 desugarTypeDeclarationsModule
2323) where
2424
@@ -27,6 +27,7 @@ import Control.Applicative
2727#endif
2828import Control.Monad (forM)
2929import Control.Monad.Error.Class (MonadError(..))
30+import Control.Monad.Writer.Class (MonadWriter(tell))
3031
3132import Language.PureScript.AST
3233import Language.PureScript.Names
@@ -37,36 +38,38 @@ import Language.PureScript.Traversals
3738-- |
3839-- Replace all top level type declarations in a module with type annotations
3940--
40−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
41+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
4142desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
4243 rethrow (addHint (ErrorInModule name)) $
4344 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
44−
45−-- |
46−-- Replace all top level type declarations with type annotations
47−--
48−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
49−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
50− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
51− return (PositionedDeclaration pos com d' : ds')
52−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
53− (_, nameKind, val) <- fromValueDeclaration d
54− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
5545 where
56− fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
57− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
58− fromValueDeclaration (PositionedDeclaration pos com d') = do
59− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
60− return (ident, nameKind, PositionedValue pos com val)
61− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
62−desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
63−desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
64− let (_, f, _) = everywhereOnValuesTopDownM return go return
65− f' (Left gs) = Left <$> mapM (pairM return f) gs
66− f' (Right v) = Right <$> f v
67− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
68− where
69− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
70− go other = return other
71−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
72−desugarTypeDeclarations [] = return []
46+
47+ desugarTypeDeclarations :: [Declaration] -> m [Declaration]
48+ desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
50+ return (PositionedDeclaration pos com d' : ds')
51+ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
52+ (_, nameKind, val) <- fromValueDeclaration d
53+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
54+ where
55+ fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
56+ fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
57+ fromValueDeclaration (PositionedDeclaration pos com d') = do
58+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
59+ return (ident, nameKind, PositionedValue pos com val)
60+ 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)
67+ let (_, f, _) = everywhereOnValuesTopDownM return go return
68+ f' (Left gs) = Left <$> mapM (pairM return f) gs
69+ f' (Right v) = Right <$> f v
70+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
71+ where
72+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
73+ go other = return other
74+ desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
75+ desugarTypeDeclarations [] = return []