1dcf381 · rowtype-yoga/purescript-native

25#if __GLASGOW_HASKELL__ < 710

26import Control.Applicative

27#endif

28−import Control.Monad (forM)

28+import Control.Monad (forM, when)

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

30import Control.Monad.Writer.Class (MonadWriter(tell))

31

41desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

42desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

43 rethrow (addHint (ErrorInModule name)) $

44− Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

44+ Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps

45 where

46

47− desugarTypeDeclarations :: [Declaration] -> m [Declaration]

47+ desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]

48− desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

48+ desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do

49− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

49+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)

50 return (PositionedDeclaration pos com d' : ds')

51− desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

51+ desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do

52 (_, 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)

54 where

55 fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)

56 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

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

61+ desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

62− desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

62+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do

63+ -- At the top level, match a type signature or emit a warning.

63− case val of

64+ when reqd $ case val of

64− Right TypedValue{} -> return ()

65+ Right TypedValue{} -> return ()

65− Left _ -> error "desugarTypeDeclarations: cases were not desugared"

66+ Left _ -> error "desugarTypeDeclarations: cases were not desugared"

66− _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

67+ _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

67 let (_, f, _) = everywhereOnValuesTopDownM return go return

68 let (_, f, _) = everywhereOnValuesTopDownM return go return

68 f' (Left gs) = Left <$> mapM (pairM return f) gs

69 f' (Left gs) = Left <$> mapM (pairM return f) gs

69 f' (Right v) = Right <$> f v

70 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

71 where

72 where

72− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

73+ go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'

73 go other = return other

74 go other = return other

74− desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

75+ desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds

75− desugarTypeDeclarations [] = return []

76+ desugarTypeDeclarations _ [] = return []