19f13b9 · rowtype-yoga/purescript-native

src/Control/Monad/Unify.hs+6−4

compare with golang

unifiedsplit

@@ -20,10 +20,12 @@

20{-# LANGUAGE MultiParamTypeClasses #-}

21{-# LANGUAGE FunctionalDependencies #-}

22{-# LANGUAGE UndecidableInstances #-}

23+{-# LANGUAGE OverloadedStrings #-}

23

24

24module Control.Monad.Unify where

25module Control.Monad.Unify where

25

26

26import Data.Maybe

27import Data.Maybe

28+import Data.String (IsString)

27import Data.Monoid

29import Data.Monoid

28

30

29import Control.Applicative

31import Control.Applicative

@@ -86,7 +88,7 @@ defaultUnifyState = UnifyState 0 mempty

86-- |

88-- |

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

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

88--

90--

89−newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }

91+newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }

90 deriving (Functor, Monad, Applicative, MonadPlus)

92 deriving (Functor, Monad, Applicative, MonadPlus)

91

93

92instance (MonadState s m) => MonadState s (UnifyT t m) where

94instance (MonadState s m) => MonadState s (UnifyT t m) where

@@ -112,7 +114,7 @@ substituteOne u t = Substitution $ M.singleton u t

112-- |

114-- |

113-- Replace a unification variable with the specified value in the current substitution

115-- Replace a unification variable with the specified value in the current substitution

114--

116--

115−(=:=) :: (Error e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()

117+(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()

116(=:=) u t' = do

118(=:=) u t' = do

117 st <- UnifyT get

119 st <- UnifyT get

118 let sub = unifyCurrentSubstitution st

120 let sub = unifyCurrentSubstitution st

@@ -127,10 +129,10 @@ substituteOne u t = Substitution $ M.singleton u t

127-- |

129-- |

128-- Perform the occurs check, to make sure a unification variable does not occur inside a value

130-- Perform the occurs check, to make sure a unification variable does not occur inside a value

129--

131--

130−occursCheck :: (Error e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()

132+occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()

131occursCheck u t =

133occursCheck u t =

132 case isUnknown t of

134 case isUnknown t of

133− Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError . strMsg $ "Occurs check fails"

135+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"

134 _ -> return ()

136 _ -> return ()

135

137

136-- |

138-- |

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

@@ -17,11 +17,11 @@

17module Language.PureScript.Errors where

18

19import Data.Either (lefts, rights)

20+import Data.String (IsString(..))

20import Data.List (intersperse, intercalate)

21import Data.List (intersperse, intercalate)

21import Data.Monoid

22import Data.Monoid

22

23

23import Control.Monad.Except

24import Control.Monad.Except

24−import Control.Monad.Error (Error(..))

25import Control.Applicative ((<$>))

26

27import Language.PureScript.AST

@@ -74,9 +74,14 @@ instance Monoid ErrorStack where

74 mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]

75 mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]

76

77−instance Error ErrorStack where

77+-- TODO: Remove strMsg, the IsString instance, and unnecessary

78+-- OverloadedStrings pragmas. See #745

79+-- | Create an ErrorStack from a string

80+strMsg :: String -> ErrorStack

78− strMsg s = ErrorStack [CompileError s Nothing Nothing]

81+strMsg s = ErrorStack [CompileError s Nothing Nothing]

79− noMsg = ErrorStack []

82+

83+instance IsString ErrorStack where

84+ fromString = strMsg

80

85

81prettyPrintErrorStack :: Bool -> ErrorStack -> String

86prettyPrintErrorStack :: Bool -> ErrorStack -> String

82prettyPrintErrorStack printFullStack (ErrorStack es) =

87prettyPrintErrorStack printFullStack (ErrorStack es) =

src/Language/PureScript/Sugar/CaseDeclarations.hs+1−2

@@ -24,8 +24,7 @@ import Data.List (nub, groupBy)

24

25import Control.Applicative

26import Control.Monad ((<=<), forM, join, unless, replicateM)

27−import Control.Monad.Except

27+import Control.Monad.Except (throwError)

28−import Control.Monad.Error (Error(..))

29

28

30import Language.PureScript.Names

29import Language.PureScript.Names

31import Language.PureScript.AST

30import Language.PureScript.AST

src/Language/PureScript/Sugar/Names.hs−1

@@ -22,7 +22,6 @@ import Data.Monoid ((<>))

22

23import Control.Applicative (Applicative(..), (<$>), (<*>))

24import Control.Monad.Except

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

26

25

27import qualified Data.Map as M

26import qualified Data.Map as M

28

27

src/Language/PureScript/Sugar/Operators.hs−1

@@ -33,7 +33,6 @@ import Language.PureScript.Supply

33import Control.Applicative

34import Control.Monad.State

35import Control.Monad.Except

36−import Control.Monad.Error (Error(..))

37

36

38import Data.Monoid ((<>))

37import Data.Monoid ((<>))

39import Data.Function (on)

38import Data.Function (on)

src/Language/PureScript/Sugar/TypeClasses.hs−1

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

35import Control.Applicative

36import Control.Arrow (first, second)

37import Control.Monad.Except

38−import Control.Monad.Error (Error(..))

39import Control.Monad.State

38import Control.Monad.State

40import Data.List ((\\), find)

39import Data.List ((\\), find)

41import Data.Maybe (catMaybes, mapMaybe, isJust)

40import Data.Maybe (catMaybes, mapMaybe, isJust)

src/Language/PureScript/Sugar/TypeDeclarations.hs−2

@@ -23,8 +23,6 @@ import Data.Monoid ((<>))

23

24import Control.Applicative

25import Control.Monad.Except

26−import Control.Monad.Error (Error(..))

27−import Control.Monad (forM)

28

26

29import Language.PureScript.AST

27import Language.PureScript.AST

30import Language.PureScript.Names

28import Language.PureScript.Names

src/Language/PureScript/TypeChecker.hs−1

@@ -33,7 +33,6 @@ import qualified Data.Map as M

33

34import Control.Monad.State

35import Control.Monad.Except

36−import Control.Monad.Error (Error(..))

37

36

38import Language.PureScript.Types

37import Language.PureScript.Types

39import Language.PureScript.Names

38import Language.PureScript.Names

src/Language/PureScript/TypeChecker/Entailment.hs+1−1

@@ -26,9 +26,9 @@ import qualified Data.Map as M

26import Control.Applicative

27import Control.Arrow (Arrow(..))

28import Control.Monad.Except

29−import Control.Monad.Error (Error(..))

30

29

31import Language.PureScript.AST

30import Language.PureScript.AST

31+import Language.PureScript.Errors

32import Language.PureScript.Environment

33import Language.PureScript.Names

34import Language.PureScript.Pretty

src/Language/PureScript/TypeChecker/Kinds.hs−1

@@ -32,7 +32,6 @@ import qualified Data.Map as M

32import Control.Arrow (second)

33import Control.Applicative

34import Control.Monad.Except

35−import Control.Monad.Error (Error(..))

36import Control.Monad.State

35import Control.Monad.State

37import Control.Monad.Unify

36import Control.Monad.Unify

38

37

src/Language/PureScript/TypeChecker/Monad.hs+6−7

@@ -14,7 +14,7 @@

14-----------------------------------------------------------------------------

15

16{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,

17− MultiParamTypeClasses, FlexibleContexts #-}

17+ MultiParamTypeClasses, FlexibleContexts, GADTs #-}

18

19module Language.PureScript.TypeChecker.Monad where

20

@@ -23,7 +23,6 @@ import qualified Data.Map as M

23

24import Control.Applicative

25import Control.Monad.Except

26−import Control.Monad.Error (Error(..))

27import Control.Monad.Reader.Class

26import Control.Monad.Reader.Class

28import Control.Monad.State

27import Control.Monad.State

29import Control.Monad.Unify

28import Control.Monad.Unify

@@ -110,7 +109,7 @@ makeBindingGroupVisible action = do

110-- |

109-- |

111-- Lookup the type of a value by name in the @Environment@

110-- Lookup the type of a value by name in the @Environment@

112--

111--

113−lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

112+lookupVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

114lookupVariable currentModule (Qualified moduleName var) = do

113lookupVariable currentModule (Qualified moduleName var) = do

115 env <- getEnv

114 env <- getEnv

116 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

115 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -120,7 +119,7 @@ lookupVariable currentModule (Qualified moduleName var) = do

120-- |

119-- |

121-- Lookup the visibility of a value by name in the @Environment@

120-- Lookup the visibility of a value by name in the @Environment@

122--

121--

123−getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

122+getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

124getVisibility currentModule (Qualified moduleName var) = do

123getVisibility currentModule (Qualified moduleName var) = do

125 env <- getEnv

124 env <- getEnv

126 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

125 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -130,7 +129,7 @@ getVisibility currentModule (Qualified moduleName var) = do

130-- |

129-- |

131-- Assert that a name is visible

130-- Assert that a name is visible

132--

131--

133−checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

132+checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

134checkVisibility currentModule name@(Qualified _ var) = do

133checkVisibility currentModule name@(Qualified _ var) = do

135 vis <- getVisibility currentModule name

134 vis <- getVisibility currentModule name

136 case vis of

135 case vis of

@@ -140,7 +139,7 @@ checkVisibility currentModule name@(Qualified _ var) = do

140-- |

139-- |

141-- Lookup the kind of a type by name in the @Environment@

140-- Lookup the kind of a type by name in the @Environment@

142--

141--

143−lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

142+lookupTypeVariable :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

144lookupTypeVariable currentModule (Qualified moduleName name) = do

143lookupTypeVariable currentModule (Qualified moduleName name) = do

145 env <- getEnv

144 env <- getEnv

146 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

145 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

@@ -173,7 +172,7 @@ data CheckState = CheckState {

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

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

174--

173--

175newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }

174newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }

176− deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack)

175+ deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)

177

176

178-- |

177-- |

179-- Get the current @Environment@

178-- Get the current @Environment@

src/Language/PureScript/TypeChecker/Subsumption.hs−1

@@ -23,7 +23,6 @@ import Data.Ord (comparing)

23

24import Control.Applicative

25import Control.Monad.Except

26−import Control.Monad.Error (Error(..))

27import Control.Monad.Unify

26import Control.Monad.Unify

28

27

29import Language.PureScript.AST

28import Language.PureScript.AST

src/Language/PureScript/TypeChecker/Synonyms.hs+5−5

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

15

16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}

16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, GADTs #-}

17

18module Language.PureScript.TypeChecker.Synonyms (

19 saturateAllTypeSynonyms,

@@ -29,10 +29,10 @@ import qualified Data.Map as M

29

30import Control.Applicative

31import Control.Monad.Except

32−import Control.Monad.Error (Error(..))

33import Control.Monad.State

32import Control.Monad.State

34

33

35import Language.PureScript.Environment

34import Language.PureScript.Environment

35+import Language.PureScript.Errors

36import Language.PureScript.Names

37import Language.PureScript.TypeChecker.Monad

38import Language.PureScript.Types

@@ -83,7 +83,7 @@ replaceAllTypeSynonyms' env d =

83 in

84 saturateAllTypeSynonyms syns d

85

86−replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

86+replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

87replaceAllTypeSynonyms d = do

88 env <- getEnv

89 either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

@@ -99,12 +99,12 @@ expandTypeSynonym' env name args =

99 replaceAllTypeSynonyms' env repl

100 Nothing -> error "Type synonym was not defined"

101

102−expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

102+expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

103expandTypeSynonym name args = do

104 env <- getEnv

105 either (throwError . strMsg) return $ expandTypeSynonym' env name args

106

107−expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

107+expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

108expandAllTypeSynonyms = everywhereOnTypesTopDownM go

109 where

110 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

src/Language/PureScript/TypeChecker/Types.hs+4−4

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

15

16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}

16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}

17

18module Language.PureScript.TypeChecker.Types (

19 typesOf

@@ -40,10 +40,10 @@ import Data.List

40import Data.Maybe (fromMaybe)

41import Data.Monoid

42import qualified Data.Map as M

43+import Data.String (IsString)

43

44

44import Control.Applicative

45import Control.Applicative

45import Control.Monad.Except

46import Control.Monad.Except

46−import Control.Monad.Error (Error(..))

47import Control.Monad.State

48import Control.Monad.Unify

49

@@ -674,5 +674,5 @@ meet e1 e2 t1 t2 = do

674-- |

675-- Ensure a set of property names and value does not contain duplicate labels

676--

677−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()

677+ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m ()

678−ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps

678+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

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

@@ -31,7 +31,6 @@ import Data.Monoid

31import qualified Data.HashMap.Strict as H

32

33import Control.Monad.Except

34−import Control.Monad.Error (Error(..))

35import Control.Monad.Unify

34import Control.Monad.Unify

36

35

37import Language.PureScript.Environment

36import Language.PureScript.Environment