19f13b9 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Remove all use of the Error typeclass (from mtl)

* Import Control.Monad.Except everywhere instead * use the IsString typeclass as a temporary hack * Also define a new `strMsg :: String -> ErrorStack` in order to reduce the amount of code that needs changing

commit19f13b9b5a5adc3048521d1ce6086a2538da3cc8 authorHarry Garrood <harry@garrood.me> dateFri 20 Feb 2015, 00:52 (12 years ago) parent4da4ed6

15 files changed+32−36

compare with golang

unifiedsplit

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

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

2020{-# LANGUAGE MultiParamTypeClasses #-}

2121{-# LANGUAGE FunctionalDependencies #-}

2222{-# LANGUAGE UndecidableInstances #-}

23+{-# LANGUAGE OverloadedStrings #-}

2324

2425module Control.Monad.Unify where

2526

2627import Data.Maybe

28+import Data.String (IsString)

2729import Data.Monoid

2830

2931import Control.Applicative

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

8688-- |

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

8890--

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 }

9092 deriving (Functor, Monad, Applicative, MonadPlus)

9193

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

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

112114-- |

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

114116--

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 ()

116118(=:=) u t' = do

117119 st <- UnifyT get

118120 let sub = unifyCurrentSubstitution st

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

127129-- |

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

129131--

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 ()

131133occursCheck u t =

132134 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"

134136 _ -> return ()

135137

136138-- |

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

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

1717module Language.PureScript.Errors where

1818

1919import Data.Either (lefts, rights)

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

2021import Data.List (intersperse, intercalate)

2122import Data.Monoid

2223

2324import Control.Monad.Except

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

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

2626

2727import Language.PureScript.AST

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

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

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

7676

77−instance Error ErrorStack where

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

79− noMsg = ErrorStack []

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

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

82+

83+instance IsString ErrorStack where

84+ fromString = strMsg

8085

8186prettyPrintErrorStack :: Bool -> ErrorStack -> String

8287prettyPrintErrorStack printFullStack (ErrorStack es) =

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

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

2424

2525import Control.Applicative

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

27−import Control.Monad.Except

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

27+import Control.Monad.Except (throwError)

2928

3029import Language.PureScript.Names

3130import Language.PureScript.AST

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

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

2222

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

2424import Control.Monad.Except

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

2625

2726import qualified Data.Map as M

2827

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

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

3333import Control.Applicative

3434import Control.Monad.State

3535import Control.Monad.Except

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

3736

3837import Data.Monoid ((<>))

3938import Data.Function (on)

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

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

3535import Control.Applicative

3636import Control.Arrow (first, second)

3737import Control.Monad.Except

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

3938import Control.Monad.State

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

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

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

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

2323

2424import Control.Applicative

2525import Control.Monad.Except

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

27−import Control.Monad (forM)

2826

2927import Language.PureScript.AST

3028import Language.PureScript.Names

src/Language/PureScript/TypeChecker.hs−1

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

3333

3434import Control.Monad.State

3535import Control.Monad.Except

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

3736

3837import Language.PureScript.Types

3938import Language.PureScript.Names

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

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

2626import Control.Applicative

2727import Control.Arrow (Arrow(..))

2828import Control.Monad.Except

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

3029

3130import Language.PureScript.AST

31+import Language.PureScript.Errors

3232import Language.PureScript.Environment

3333import Language.PureScript.Names

3434import Language.PureScript.Pretty

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

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

3232import Control.Arrow (second)

3333import Control.Applicative

3434import Control.Monad.Except

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

3635import Control.Monad.State

3736import Control.Monad.Unify

3837

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

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

1414-----------------------------------------------------------------------------

1515

1616{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,

17− MultiParamTypeClasses, FlexibleContexts #-}

17+ MultiParamTypeClasses, FlexibleContexts, GADTs #-}

1818

1919module Language.PureScript.TypeChecker.Monad where

2020

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

2323

2424import Control.Applicative

2525import Control.Monad.Except

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

2726import Control.Monad.Reader.Class

2827import Control.Monad.State

2928import Control.Monad.Unify

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

110109-- |

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

112111--

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

114113lookupVariable currentModule (Qualified moduleName var) = do

115114 env <- getEnv

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

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

120119-- |

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

122121--

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

124123getVisibility currentModule (Qualified moduleName var) = do

125124 env <- getEnv

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

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

130129-- |

131130-- Assert that a name is visible

132131--

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 ()

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

135134 vis <- getVisibility currentModule name

136135 case vis of

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

140139-- |

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

142141--

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

144143lookupTypeVariable currentModule (Qualified moduleName name) = do

145144 env <- getEnv

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

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

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

174173--

175174newtype 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)

177176

178177-- |

179178-- Get the current @Environment@

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

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

2323

2424import Control.Applicative

2525import Control.Monad.Except

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

2726import Control.Monad.Unify

2827

2928import Language.PureScript.AST

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

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

1313--

1414-----------------------------------------------------------------------------

1515

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

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

1717

1818module Language.PureScript.TypeChecker.Synonyms (

1919 saturateAllTypeSynonyms,

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

2929

3030import Control.Applicative

3131import Control.Monad.Except

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

3332import Control.Monad.State

3433

3534import Language.PureScript.Environment

35+import Language.PureScript.Errors

3636import Language.PureScript.Names

3737import Language.PureScript.TypeChecker.Monad

3838import Language.PureScript.Types

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

8383 in

8484 saturateAllTypeSynonyms syns d

8585

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

8787replaceAllTypeSynonyms d = do

8888 env <- getEnv

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

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

9999 replaceAllTypeSynonyms' env repl

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

101101

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

103103expandTypeSynonym name args = do

104104 env <- getEnv

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

106106

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

108108expandAllTypeSynonyms = everywhereOnTypesTopDownM go

109109 where

110110 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

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

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

1313--

1414-----------------------------------------------------------------------------

1515

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

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

1717

1818module Language.PureScript.TypeChecker.Types (

1919 typesOf

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

4040import Data.Maybe (fromMaybe)

4141import Data.Monoid

4242import qualified Data.Map as M

43+import Data.String (IsString)

4344

4445import Control.Applicative

4546import Control.Monad.Except

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

4747import Control.Monad.State

4848import Control.Monad.Unify

4949

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

674674-- |

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

676676--

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

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

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

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

3131import qualified Data.HashMap.Strict as H

3232

3333import Control.Monad.Except

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

3534import Control.Monad.Unify

3635

3736import Language.PureScript.Environment