4236b78 · rowtype-yoga/purescript-native

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

Renamer updates

commit4236b78b7d7d1213704dc21cf4b0c59590571ede authorGary Burgess <gary.burgess@gmail.com> dateSun 13 Dec 2015, 16:40 (11 years ago) parent4b144d6

15 files changed+131−221

compare with golang

unifiedsplit

examples/passing/1697.pursnew file+24

@@ -0,0 +1,24 @@

1+module Main where

3+import Prelude

5+_2 :: forall a. a -> a

6+_2 a = a

8+x :: forall m. (Monad m) => m Unit

9+x = do

10+ _ <- pure unit

11+ pure unit

12+

13+y :: forall m. (Monad m) => m Unit

14+y = do

15+ _ <- pure unit

16+ pure unit

17+

18+wtf :: forall m. (Monad m) => m Unit

19+wtf = do

20+ _ <- pure unit

21+ let tmp = _2 1

22+ pure unit

23+

24+main = Control.Monad.Eff.Console.log "Done"

src/Control/Monad/Supply/Class.hs+5−17

@@ -1,20 +1,8 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Control.Monad.Supply.Class

4−-- Copyright : (c) PureScript 2015

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE MultiParamTypeClasses #-}

113-- |

124-- A class for monads supporting a supply of fresh names

135--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE MultiParamTypeClasses #-}

17−

186module Control.Monad.Supply.Class where

197

208import Control.Monad.Supply

@@ -22,15 +10,15 @@ import Control.Monad.State

2210

2311class (Monad m) => MonadSupply m where

2412 fresh :: m Integer

25−

13+

2614instance (Monad m) => MonadSupply (SupplyT m) where

2715 fresh = SupplyT $ do

2816 n <- get

2917 put (n + 1)

3018 return n

31−

19+

3220instance (MonadSupply m) => MonadSupply (StateT s m) where

3321 fresh = lift fresh

3422

3523freshName :: (MonadSupply m) => m String

36−freshName = liftM (('_' :) . show) fresh

24+freshName = liftM (('$' :) . show) fresh

src/Language/PureScript/CodeGen/JS.hs+4−15

@@ -1,23 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.JS

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module generates code in the simplified Javascript intermediate representation from Purescript code

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE GADTs #-}

172{-# LANGUAGE ViewPatterns #-}

183{-# LANGUAGE FlexibleContexts #-}

194{-# LANGUAGE ScopedTypeVariables #-}

205

6+-- |

7+-- This module generates code in the simplified Javascript intermediate representation from Purescript code

8+--

219module Language.PureScript.CodeGen.JS

2210 ( module AST

2311 , module Common

@@ -180,6 +168,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

180168 accessor :: Ident -> JS -> JS

181169 accessor (Ident prop) = accessorString prop

182170 accessor (Op op) = JSIndexer (JSStringLiteral op)

171+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"

183172

184173 accessorString :: String -> JS -> JS

185174 accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

src/Language/PureScript/CodeGen/JS/Common.hs+2−12

@@ -1,23 +1,12 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.Common

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

111-- |

122-- Common code generation utility functions

133--

14−-----------------------------------------------------------------------------

15−

164module Language.PureScript.CodeGen.JS.Common where

175

186import Data.Char

197import Data.List (intercalate)

208

9+import Language.PureScript.Crash

2110import Language.PureScript.Names

2211

2312-- |

@@ -33,6 +22,7 @@ identToJs :: Ident -> String

3322identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

3423identToJs (Ident name) = concatMap identCharToString name

3524identToJs (Op op) = concatMap identCharToString op

25+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

3626

3727-- |

3828-- Test if a string is a valid JS identifier without escaping.

src/Language/PureScript/Make.hs+3−16

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Make

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DataKinds #-}

162{-# LANGUAGE FlexibleContexts #-}

173{-# LANGUAGE GeneralizedNewtypeDeriving #-}

@@ -225,8 +211,9 @@ make MakeActions{..} ms = do

225211 progress $ CompilingModule moduleName

226212 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

227213 lint m

228− ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]

229− (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared

214+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do

215+ [desugared] <- desugar externs [m]

216+ runCheck' env $ typeCheckModule desugared

230217 checkExhaustiveModule env' checked

231218 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

232219 let mod' = Module ss coms moduleName regrouped exps

src/Language/PureScript/Names.hs+20−17

@@ -1,25 +1,16 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Names

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Data types for names

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE DeriveDataTypeable #-}

172{-# LANGUAGE DeriveFunctor #-}

183{-# LANGUAGE TemplateHaskell #-}

194{-# LANGUAGE GADTs #-}

205

6+-- |

7+-- Data types for names

8+--

219module Language.PureScript.Names where

2210

11+import Control.Monad (liftM)

12+import Control.Monad.Supply.Class

13+

2314import Data.List

2415import Data.Data

2516import Data.List.Split (splitOn)

@@ -38,15 +29,27 @@ data Ident

3829 -- |

3930 -- A symbolic name for an infix operator

4031 --

41− | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)

32+ | Op String

33+ -- |

34+ -- A generated name for an identifier

35+ --

36+ | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)

4237

4338runIdent :: Ident -> String

4439runIdent (Ident i) = i

4540runIdent (Op op) = op

41+runIdent (GenIdent Nothing n) = "$" ++ show n

42+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

4643

4744showIdent :: Ident -> String

48−showIdent (Ident i) = i

4945showIdent (Op op) = '(' : op ++ ")"

46+showIdent i = runIdent i

47+

48+freshIdent :: (MonadSupply m) => String -> m Ident

49+freshIdent name = liftM (GenIdent (Just name)) fresh

50+

51+freshIdent' :: (MonadSupply m) => m Ident

52+freshIdent' = liftM (GenIdent Nothing) fresh

5053

5154-- |

5255-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

src/Language/PureScript/Renamer.hs+29−29

@@ -1,22 +1,9 @@

1−-----------------------------------------------------------------------------

2−-----------------------------------------------------------------------------

3−--

4−-- Module : Language.PureScript.Renamer

6−-- License : MIT

7−--

8−-- Maintainer : Phil Freeman <paf31@cantab.net>

9−-- Stability : experimental

10−-- Portability :

11−--

12−-- |

13−-- Renaming pass that prevents shadowing of local identifiers.

14−--

15−-----------------------------------------------------------------------------

16−

171{-# LANGUAGE FlexibleContexts #-}

182{-# LANGUAGE ScopedTypeVariables #-}

193

4+-- |

5+-- Renaming pass that prevents shadowing of local identifiers.

6+--

207module Language.PureScript.Renamer (renameInModules) where

218

229import Prelude ()

@@ -25,6 +12,7 @@ import Prelude.Compat

2512import Control.Monad.State

2613

2714import Data.List (find)

15+import Data.Maybe (fromJust, fromMaybe)

2816

2917import qualified Data.Map as M

3018import qualified Data.Set as S

@@ -76,19 +64,31 @@ newScope x = do

7664-- unique name is generated and stored.

7765--

7866updateScope :: Ident -> Rename Ident

79−updateScope i@(Ident name) | name == C.__unused = return i

80−updateScope name = do

81− scope <- get

82− name' <- if name `S.member` rsUsedNames scope

83− then do

84− let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

85− Just newName = find (`S.notMember` rsUsedNames scope) newNames

86− return newName

87− else return name

88− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

89− , rsUsedNames = S.insert name' (rsUsedNames s)

90− }

91− return name'

67+updateScope ident =

68+ case ident of

69+ Ident name

70+ | name == C.__unused -> return ident

71+ | last name == '\'' -> go ident $ Ident $ init name ++ "ʹ" -- '\x02b9'

72+ GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)

73+ _ -> go ident ident

74+ where

75+ go :: Ident -> Ident -> Rename Ident

76+ go keyName baseName = do

77+ scope <- get

78+ let usedNames = rsUsedNames scope

79+ name' =

80+ if baseName `S.member` usedNames

81+ then getNewName usedNames baseName

82+ else baseName

83+ modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)

84+ , rsUsedNames = S.insert name' (rsUsedNames s)

85+ }

86+ return name'

87+ getNewName :: S.Set Ident -> Ident -> Ident

88+ getNewName usedNames name =

89+ fromJust $ find

90+ (`S.notMember` usedNames)

91+ [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]

9292

9393-- |

9494-- Finds the new name to use for an ident.

src/Language/PureScript/Sugar/CaseDeclarations.hs+7−21

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CaseDeclarations

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

114-- |

125-- This module implements the desugaring pass which replaces top-level binders with

136-- case expressions.

147--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

208module Language.PureScript.Sugar.CaseDeclarations (

219 desugarCases,

2210 desugarCasesModule

@@ -88,7 +76,7 @@ desugarAbs = flip parU f

8876

8977 replace :: Expr -> m Expr

9078 replace (Abs (Right binder) val) = do

91− ident <- Ident <$> freshName

79+ ident <- freshIdent'

9280 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

9381 replace other = return other

9482

@@ -136,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

136124 isVarBinder _ = False

137125

138126 fromVarBinder :: Binder -> m Ident

139− fromVarBinder NullBinder = Ident <$> freshName

127+ fromVarBinder NullBinder = freshIdent'

140128 fromVarBinder (VarBinder name) = return name

141129 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

142130 fromVarBinder (TypedBinder _ b) = fromVarBinder b

@@ -165,7 +153,7 @@ makeCaseDeclaration ident alternatives = do

165153 argNames = map join $ foldl1 resolveNames namedArgs

166154 args <- if allUnique (catMaybes argNames)

167155 then mapM argName argNames

168− else replicateM (length argNames) (Ident <$> freshName)

156+ else replicateM (length argNames) freshIdent'

169157 let vars = map (Var . Qualified Nothing) args

170158 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]

171159 value = foldr (Abs . Left) (Case vars binders) args

@@ -190,9 +178,7 @@ makeCaseDeclaration ident alternatives = do

190178

191179 argName :: Maybe Ident -> m Ident

192180 argName (Just name) = return name

193− argName _ = do

194− name <- freshName

195− return (Ident name)

181+ argName _ = freshIdent'

196182

197183 -- Combine two lists of potential names from two case alternatives

198184 -- by zipping correspoding columns.

src/Language/PureScript/Sugar/DoNotation.hs+4−16

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.DoNotation

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

114-- |

125-- This module implements the desugaring pass which replaces do-notation statements with

136-- appropriate calls to bind from the Prelude.Monad type class.

147--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

208module Language.PureScript.Sugar.DoNotation (

219 desugarDoModule

2210) where

@@ -68,7 +56,7 @@ desugarDo d =

6856 return $ App (App bind val) (Abs (Left ident) rest')

6957 go (DoNotationBind binder val : rest) = do

7058 rest' <- go rest

71− ident <- Ident <$> freshName

59+ ident <- freshIdent'

7260 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

7361 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

7462 go (DoNotationLet ds : rest) = do

src/Language/PureScript/Sugar/ObjectWildcards.hs+3−17

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.ObjectWildcards

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE FlexibleContexts #-}

162{-# LANGUAGE ScopedTypeVariables #-}

173

@@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

4430 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

4531 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

4632 desugarExpr (ObjectUpdater Nothing ps) = do

47− obj <- Ident <$> freshName

33+ obj <- freshIdent'

4834 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

4935 desugarExpr (ObjectGetter prop) = do

50− arg <- Ident <$> freshName

36+ arg <- freshIdent'

5137 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

5238 desugarExpr e = return e

5339

@@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

6349 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

6450 mkProp (name, Just e) = return (Nothing, (name, e))

6551 mkProp (name, Nothing) = do

66− arg <- Ident <$> freshName

52+ arg <- freshIdent'

6753 return (Just arg, (name, Var (Qualified Nothing arg)))

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

@@ -178,6 +178,6 @@ desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> trav

178178 goExpr :: Expr -> m Expr

179179 goExpr (OperatorSection op (Left val)) = return $ App op val

180180 goExpr (OperatorSection op (Right val)) = do

181− arg <- Ident <$> freshName

181+ arg <- freshIdent'

182182 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

183183 goExpr other = return other

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+6−18

@@ -1,18 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.TypeClasses.Deriving

4−-- Copyright : (c) Gershom Bazerman 2015

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the generic deriving elaboration that takes place during desugaring.

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE FlexibleContexts #-}

172{-# LANGUAGE MultiParamTypeClasses #-}

183{-# LANGUAGE OverloadedStrings #-}

@@ -20,6 +5,9 @@

205{-# LANGUAGE RankNTypes #-}

216{-# LANGUAGE ScopedTypeVariables #-}

227

8+-- |

9+-- This module implements the generic deriving elaboration that takes place during desugaring.

10+--

2311module Language.PureScript.Sugar.TypeClasses.Deriving (

2412 deriveInstances

2513) where

@@ -32,7 +20,7 @@ import Data.Maybe (fromMaybe)

3220import Data.Ord (comparing)

3321

3422import Control.Monad (replicateM)

35−import Control.Monad.Supply.Class (MonadSupply, freshName)

23+import Control.Monad.Supply.Class (MonadSupply)

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

3725

3826import Language.PureScript.Crash

@@ -106,7 +94,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

10694

10795 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

10896 mkCtorClause (ctorName, tys) = do

109− idents <- replicateM (length tys) (fmap Ident freshName)

97+ idents <- replicateM (length tys) freshIdent'

11098 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

11199 where

112100 caseResult idents =

@@ -172,7 +160,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

172160

173161 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

174162 mkAlternative (ctorName, tys) = do

175− idents <- replicateM (length tys) (fmap Ident freshName)

163+ idents <- replicateM (length tys) freshIdent'

176164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

177165 . Right

178166 $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

src/Language/PureScript/TypeChecker.hs+3−2

@@ -25,6 +25,7 @@ import Data.Foldable (for_, traverse_)

2525import qualified Data.Map as M

2626

2727import Control.Monad (when, unless, void, forM, forM_)

28+import Control.Monad.Supply.Class (MonadSupply)

2829import Control.Monad.State.Class (MonadState(..), modify)

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

3031import Control.Monad.Writer.Class (MonadWriter(..))

@@ -179,7 +180,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

179180-- * Process module imports

180181--

181182typeCheckAll :: forall m.

182− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

183+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

183184 ModuleName ->

184185 [DeclarationRef] ->

185186 [Declaration] ->

@@ -335,7 +336,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

335336-- required by exported members are also exported.

336337--

337338typeCheckModule :: forall m.

338− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

339+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

339340 Module ->

340341 m Module

341342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

src/Language/PureScript/TypeChecker/Monad.hs+1−9

@@ -57,14 +57,13 @@ data CheckState = CheckState

5757 , checkNextKind :: Int -- ^ The next kind unification variable

5858 , checkNextSkolem :: Int -- ^ The next skolem variable

5959 , checkNextSkolemScope :: Int -- ^ The next skolem scope constant

60− , checkNextDictName :: Int -- ^ The next type class dictionary name

6160 , checkCurrentModule :: Maybe ModuleName -- ^ The current module

6261 , checkSubstitution :: Substitution -- ^ The current substitution

6362 }

6463

6564-- | Create an empty @CheckState@

6665emptyCheckState :: Environment -> CheckState

67−emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution

66+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

6867

6968-- | Unification variables

7069type Unknown = Int

@@ -202,13 +201,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()

202201guardWith _ True = return ()

203202guardWith e False = throwError e

204203

205−-- | Generate new type class dictionary name

206−freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int

207−freshDictionaryName = do

208− n <- checkNextDictName <$> get

209− modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }

210− return n

211−

212204-- | Run a computation in the substitution monad, generating a return value and the final substitution.

213205liftUnify ::

214206 (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

src/Language/PureScript/TypeChecker/Types.hs+19−31

@@ -1,23 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Types

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the type checker

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE FlexibleContexts #-}

172{-# LANGUAGE ScopedTypeVariables #-}

183{-# LANGUAGE MultiParamTypeClasses #-}

194{-# LANGUAGE OverloadedStrings #-}

205

6+-- |

7+-- This module implements the type checker

8+--

219module Language.PureScript.TypeChecker.Types (

2210 typesOf

2311) where

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

4836

4937import Control.Monad

5038import Control.Monad.State.Class (MonadState(..), gets)

39+import Control.Monad.Supply.Class (MonadSupply)

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

5241import Control.Monad.Writer.Class (MonadWriter(..))

5342

@@ -72,7 +61,7 @@ import Language.PureScript.Types

7261-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

7362-- type class dictionaries and type annotations.

7463typesOf ::

75− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

64+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

7665 ModuleName ->

7766 [(Ident, Expr)] ->

7867 m [(Ident, (Expr, Type))]

@@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do

129118 return (untyped, typed, dict, untypedDict)

130119

131120checkTypedBindingGroupElement ::

132− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

121+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

133122 ModuleName ->

134123 (Ident, (Expr, Type, Bool)) ->

135124 TypeData ->

@@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

148137 return (ident, (val'', ty''))

149138

150139typeForBindingGroupElement ::

151− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

140+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

152141 Bool ->

153142 (Ident, Expr) ->

154143 TypeData ->

@@ -218,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

218207

219208-- | Infer a type for a value, rethrowing any error to provide a more useful error message

220209infer ::

221− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

210+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

222211 Expr ->

223212 m Expr

224213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

225214

226215-- | Infer a type for a value

227216infer' ::

228− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

217+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

229218 Expr ->

230219 m Expr

231220infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

@@ -312,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

312301infer' _ = internalError "Invalid argument to infer"

313302

314303inferLetBinding ::

315− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

304+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

316305 [Declaration] ->

317306 [Declaration] ->

318307 Expr ->

@@ -423,7 +412,7 @@ binderRequiresMonotype _ = True

423412

424413-- | Instantiate polytypes only when necessitated by a binder.

425414instantiateForBinders ::

426− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

415+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

427416 [Expr] ->

428417 [CaseAlternative] ->

429418 m ([Expr], [Type])

@@ -440,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do

440429-- Check the types of the return values in a set of binders in a case statement

441430--

442431checkBinders ::

443− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

432+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

444433 [Type] ->

445434 Type ->

446435 [CaseAlternative] ->

@@ -470,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

470459-- Check the type of a value, rethrowing errors to provide a better error message

471460--

472461check ::

473− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

462+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

474463 Expr ->

475464 Type ->

476465 m Expr

@@ -480,7 +469,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

480469-- Check the type of a value

481470--

482471check' :: forall m.

483− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

472+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

484473 Expr ->

485474 Type ->

486475 m Expr

@@ -495,9 +484,8 @@ check' val (ForAll ident ty _) = do

495484 val' <- check skVal sk

496485 return $ TypedValue True val' (ForAll ident ty (Just scope))

497486check' val t@(ConstrainedType constraints ty) = do

498− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

499− n <- freshDictionaryName

500− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

487+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->

488+ freshIdent ("dict" ++ className)

501489 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

502490 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

503491 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

@@ -639,7 +627,7 @@ check' val ty = do

639627-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

640628--

641629checkProperties ::

642− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

630+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

643631 Expr ->

644632 [(String, Expr)] ->

645633 Type ->

@@ -671,7 +659,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh

671659

672660-- | Check the type of a function application, rethrowing errors to provide a better error message

673661checkFunctionApplication ::

674− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

662+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

675663 Expr ->

676664 Type ->

677665 Expr ->

@@ -683,7 +671,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication

683671

684672-- | Check the type of a function application

685673checkFunctionApplication' ::

686− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

674+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

687675 Expr ->

688676 Type ->

689677 Expr ->