git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1710 from purescript/renamer-updates
f5ed125Gary Burgess
examples/passing/1697.pursnew file+24
compare with golang
unifiedsplit
@@ -0,0 +1,24 @@
1+module Main where
2+
3+import Prelude
4+
5+_2 :: forall a. a -> a
6+_2 a = a
7+
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−-----------------------------------------------------------------------------
1+{-# LANGUAGE MultiParamTypeClasses #-}
2−--
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−--
11-- |
3-- |
12-- A class for monads supporting a supply of fresh names
4-- A class for monads supporting a supply of fresh names
13--
5--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE MultiParamTypeClasses #-}
17−
18module Control.Monad.Supply.Class where
6module Control.Monad.Supply.Class where
19
7
20import Control.Monad.Supply
8import Control.Monad.Supply
@@ -22,15 +10,15 @@ import Control.Monad.State
22
10
23class (Monad m) => MonadSupply m where
11class (Monad m) => MonadSupply m where
24 fresh :: m Integer
12 fresh :: m Integer
25−
13+
26instance (Monad m) => MonadSupply (SupplyT m) where
14instance (Monad m) => MonadSupply (SupplyT m) where
27 fresh = SupplyT $ do
15 fresh = SupplyT $ do
28 n <- get
16 n <- get
29 put (n + 1)
17 put (n + 1)
30 return n
18 return n
31−
19+
32instance (MonadSupply m) => MonadSupply (StateT s m) where
20instance (MonadSupply m) => MonadSupply (StateT s m) where
33 fresh = lift fresh
21 fresh = lift fresh
34
22
35freshName :: (MonadSupply m) => m String
23freshName :: (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−
16{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
17{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE ViewPatterns #-}
18{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
20
5
6+-- |
7+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
8+--
21module Language.PureScript.CodeGen.JS
9module Language.PureScript.CodeGen.JS
22 ( module AST
10 ( module AST
23 , module Common
11 , module Common
@@ -180,6 +168,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
180 accessor :: Ident -> JS -> JS
168 accessor :: Ident -> JS -> JS
181 accessor (Ident prop) = accessorString prop
169 accessor (Ident prop) = accessorString prop
182 accessor (Op op) = JSIndexer (JSStringLiteral op)
170 accessor (Op op) = JSIndexer (JSStringLiteral op)
171+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"
183
172
184 accessorString :: String -> JS -> JS
173 accessorString :: String -> JS -> JS
185 accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
174 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−--
11-- |
1-- |
12-- Common code generation utility functions
2-- Common code generation utility functions
13--
3--
14−-----------------------------------------------------------------------------
15−
16module Language.PureScript.CodeGen.JS.Common where
4module Language.PureScript.CodeGen.JS.Common where
17
5
18import Data.Char
6import Data.Char
19import Data.List (intercalate)
7import Data.List (intercalate)
20
8
9+import Language.PureScript.Crash
21import Language.PureScript.Names
10import Language.PureScript.Names
22
11
23-- |
12-- |
@@ -33,6 +22,7 @@ identToJs :: Ident -> String
33identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
22identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
34identToJs (Ident name) = concatMap identCharToString name
23identToJs (Ident name) = concatMap identCharToString name
35identToJs (Op op) = concatMap identCharToString op
24identToJs (Op op) = concatMap identCharToString op
25+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
36
26
37-- |
27-- |
38-- Test if a string is a valid JS identifier without escaping.
28-- 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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
15{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
16{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -225,8 +211,9 @@ make MakeActions{..} ms = do
225 progress $ CompilingModule moduleName
211 progress $ CompilingModule moduleName
226 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
212 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
227 lint m
213 lint m
228− ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
214+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
215+ [desugared] <- desugar externs [m]
229− (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
216+ runCheck' env $ typeCheckModule desugared
230 checkExhaustiveModule env' checked
217 checkExhaustiveModule env' checked
231 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
218 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
232 let mod' = Module ss coms moduleName regrouped exps
219 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−
16{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
17{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE DeriveFunctor #-}
18{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
20
5
6+-- |
7+-- Data types for names
8+--
21module Language.PureScript.Names where
9module Language.PureScript.Names where
22
10
11+import Control.Monad (liftM)
12+import Control.Monad.Supply.Class
13+
23import Data.List
14import Data.List
24import Data.Data
15import Data.Data
25import Data.List.Split (splitOn)
16import Data.List.Split (splitOn)
@@ -38,15 +29,27 @@ data Ident
38 -- |
29 -- |
39 -- A symbolic name for an infix operator
30 -- A symbolic name for an infix operator
40 --
31 --
32+ | Op String
33+ -- |
34+ -- A generated name for an identifier
35+ --
41− | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)
36+ | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)
42
37
43runIdent :: Ident -> String
38runIdent :: Ident -> String
44runIdent (Ident i) = i
39runIdent (Ident i) = i
45runIdent (Op op) = op
40runIdent (Op op) = op
41+runIdent (GenIdent Nothing n) = "$" ++ show n
42+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
46
43
47showIdent :: Ident -> String
44showIdent :: Ident -> String
48−showIdent (Ident i) = i
49showIdent (Op op) = '(' : op ++ ")"
45showIdent (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
50
53
51-- |
54-- |
52-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
55-- 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
5−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
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−
17{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
18{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
19
3
4+-- |
5+-- Renaming pass that prevents shadowing of local identifiers.
6+--
20module Language.PureScript.Renamer (renameInModules) where
7module Language.PureScript.Renamer (renameInModules) where
21
8
22import Prelude ()
9import Prelude ()
@@ -25,6 +12,7 @@ import Prelude.Compat
25import Control.Monad.State
12import Control.Monad.State
26
13
27import Data.List (find)
14import Data.List (find)
15+import Data.Maybe (fromJust, fromMaybe)
28
16
29import qualified Data.Map as M
17import qualified Data.Map as M
30import qualified Data.Set as S
18import qualified Data.Set as S
@@ -76,19 +64,31 @@ newScope x = do
76-- unique name is generated and stored.
64-- unique name is generated and stored.
77--
65--
78updateScope :: Ident -> Rename Ident
66updateScope :: Ident -> Rename Ident
67+updateScope ident =
68+ case ident of
69+ Ident name
79−updateScope i@(Ident name) | name == C.__unused = return i
70+ | name == C.__unused -> return ident
80−updateScope name = do
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
81− scope <- get
77+ scope <- get
82− name' <- if name `S.member` rsUsedNames scope
78+ let usedNames = rsUsedNames scope
83− then do
79+ name' =
84− let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
80+ if baseName `S.member` usedNames
85− Just newName = find (`S.notMember` rsUsedNames scope) newNames
81+ then getNewName usedNames baseName
86− return newName
82+ else baseName
87− else return name
88− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
83+ modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)
89− , rsUsedNames = S.insert name' (rsUsedNames s)
84+ , rsUsedNames = S.insert name' (rsUsedNames s)
90− }
85+ }
91− return name'
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..] ]
92
92
93-- |
93-- |
94-- Finds the new name to use for an ident.
94-- Finds the new name to use for an ident.
src/Language/PureScript/Sugar/CaseDeclarations.hs+7−21
@@ -1,22 +1,10 @@
1−-----------------------------------------------------------------------------
1+{-# LANGUAGE FlexibleContexts #-}
2−--
2+{-# LANGUAGE ScopedTypeVariables #-}
3−-- Module : Language.PureScript.CaseDeclarations
3+
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11-- |
4-- |
12-- This module implements the desugaring pass which replaces top-level binders with
5-- This module implements the desugaring pass which replaces top-level binders with
13-- case expressions.
6-- case expressions.
14--
7--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
20module Language.PureScript.Sugar.CaseDeclarations (
8module Language.PureScript.Sugar.CaseDeclarations (
21 desugarCases,
9 desugarCases,
22 desugarCasesModule
10 desugarCasesModule
@@ -88,7 +76,7 @@ desugarAbs = flip parU f
88
76
89 replace :: Expr -> m Expr
77 replace :: Expr -> m Expr
90 replace (Abs (Right binder) val) = do
78 replace (Abs (Right binder) val) = do
91− ident <- Ident <$> freshName
79+ ident <- freshIdent'
92 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
80 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
93 replace other = return other
81 replace other = return other
94
82
@@ -136,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
136 isVarBinder _ = False
124 isVarBinder _ = False
137
125
138 fromVarBinder :: Binder -> m Ident
126 fromVarBinder :: Binder -> m Ident
139− fromVarBinder NullBinder = Ident <$> freshName
127+ fromVarBinder NullBinder = freshIdent'
140 fromVarBinder (VarBinder name) = return name
128 fromVarBinder (VarBinder name) = return name
141 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
129 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
142 fromVarBinder (TypedBinder _ b) = fromVarBinder b
130 fromVarBinder (TypedBinder _ b) = fromVarBinder b
@@ -165,7 +153,7 @@ makeCaseDeclaration ident alternatives = do
165 argNames = map join $ foldl1 resolveNames namedArgs
153 argNames = map join $ foldl1 resolveNames namedArgs
166 args <- if allUnique (catMaybes argNames)
154 args <- if allUnique (catMaybes argNames)
167 then mapM argName argNames
155 then mapM argName argNames
168− else replicateM (length argNames) (Ident <$> freshName)
156+ else replicateM (length argNames) freshIdent'
169 let vars = map (Var . Qualified Nothing) args
157 let vars = map (Var . Qualified Nothing) args
170 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
158 binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
171 value = foldr (Abs . Left) (Case vars binders) args
159 value = foldr (Abs . Left) (Case vars binders) args
@@ -190,9 +178,7 @@ makeCaseDeclaration ident alternatives = do
190
178
191 argName :: Maybe Ident -> m Ident
179 argName :: Maybe Ident -> m Ident
192 argName (Just name) = return name
180 argName (Just name) = return name
193− argName _ = do
181+ argName _ = freshIdent'
194− name <- freshName
195− return (Ident name)
196
182
197 -- Combine two lists of potential names from two case alternatives
183 -- Combine two lists of potential names from two case alternatives
198 -- by zipping correspoding columns.
184 -- by zipping correspoding columns.
src/Language/PureScript/Sugar/DoNotation.hs+4−16
@@ -1,22 +1,10 @@
1−-----------------------------------------------------------------------------
1+{-# LANGUAGE FlexibleContexts #-}
2−--
2+{-# LANGUAGE ScopedTypeVariables #-}
3−-- Module : Language.PureScript.Sugar.DoNotation
3+
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11-- |
4-- |
12-- This module implements the desugaring pass which replaces do-notation statements with
5-- This module implements the desugaring pass which replaces do-notation statements with
13-- appropriate calls to bind from the Prelude.Monad type class.
6-- appropriate calls to bind from the Prelude.Monad type class.
14--
7--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
20module Language.PureScript.Sugar.DoNotation (
8module Language.PureScript.Sugar.DoNotation (
21 desugarDoModule
9 desugarDoModule
22) where
10) where
@@ -68,7 +56,7 @@ desugarDo d =
68 return $ App (App bind val) (Abs (Left ident) rest')
56 return $ App (App bind val) (Abs (Left ident) rest')
69 go (DoNotationBind binder val : rest) = do
57 go (DoNotationBind binder val : rest) = do
70 rest' <- go rest
58 rest' <- go rest
71− ident <- Ident <$> freshName
59+ ident <- freshIdent'
72 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
60 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
73 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
61 go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
74 go (DoNotationLet ds : rest) = do
62 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
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
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−
15{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
16{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
17
3
@@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
44 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
30 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
45 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
31 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
46 desugarExpr (ObjectUpdater Nothing ps) = do
32 desugarExpr (ObjectUpdater Nothing ps) = do
47− obj <- Ident <$> freshName
33+ obj <- freshIdent'
48 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
34 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
49 desugarExpr (ObjectGetter prop) = do
35 desugarExpr (ObjectGetter prop) = do
50− arg <- Ident <$> freshName
36+ arg <- freshIdent'
51 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
37 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
52 desugarExpr e = return e
38 desugarExpr e = return e
53
39
@@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
63 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
49 mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
64 mkProp (name, Just e) = return (Nothing, (name, e))
50 mkProp (name, Just e) = return (Nothing, (name, e))
65 mkProp (name, Nothing) = do
51 mkProp (name, Nothing) = do
66− arg <- Ident <$> freshName
52+ arg <- freshIdent'
67 return (Just arg, (name, Var (Qualified Nothing arg)))
53 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
178 goExpr :: Expr -> m Expr
178 goExpr :: Expr -> m Expr
179 goExpr (OperatorSection op (Left val)) = return $ App op val
179 goExpr (OperatorSection op (Left val)) = return $ App op val
180 goExpr (OperatorSection op (Right val)) = do
180 goExpr (OperatorSection op (Right val)) = do
181− arg <- Ident <$> freshName
181+ arg <- freshIdent'
182 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
182 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
183 goExpr other = return other
183 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−
16{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
18{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
@@ -20,6 +5,9 @@
20{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
21{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
22
7
8+-- |
9+-- This module implements the generic deriving elaboration that takes place during desugaring.
10+--
23module Language.PureScript.Sugar.TypeClasses.Deriving (
11module Language.PureScript.Sugar.TypeClasses.Deriving (
24 deriveInstances
12 deriveInstances
25) where
13) where
@@ -32,7 +20,7 @@ import Data.Maybe (fromMaybe)
32import Data.Ord (comparing)
20import Data.Ord (comparing)
33
21
34import Control.Monad (replicateM)
22import Control.Monad (replicateM)
35−import Control.Monad.Supply.Class (MonadSupply, freshName)
23+import Control.Monad.Supply.Class (MonadSupply)
36import Control.Monad.Error.Class (MonadError(..))
24import Control.Monad.Error.Class (MonadError(..))
37
25
38import Language.PureScript.Crash
26import Language.PureScript.Crash
@@ -106,7 +94,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
106
94
107 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
95 mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
108 mkCtorClause (ctorName, tys) = do
96 mkCtorClause (ctorName, tys) = do
109− idents <- replicateM (length tys) (fmap Ident freshName)
97+ idents <- replicateM (length tys) freshIdent'
110 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
98 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
111 where
99 where
112 caseResult idents =
100 caseResult idents =
@@ -172,7 +160,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch
172
160
173 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
161 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
174 mkAlternative (ctorName, tys) = do
162 mkAlternative (ctorName, tys) = do
175− idents <- replicateM (length tys) (fmap Ident freshName)
163+ idents <- replicateM (length tys) freshIdent'
176 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
177 . Right
165 . Right
178 $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
166 $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
src/Language/PureScript/TypeChecker.hs+3−2
@@ -25,6 +25,7 @@ import Data.Foldable (for_, traverse_)
25import qualified Data.Map as M
25import qualified Data.Map as M
26
26
27import Control.Monad (when, unless, void, forM, forM_)
27import Control.Monad (when, unless, void, forM, forM_)
28+import Control.Monad.Supply.Class (MonadSupply)
28import Control.Monad.State.Class (MonadState(..), modify)
29import Control.Monad.State.Class (MonadState(..), modify)
29import Control.Monad.Error.Class (MonadError(..))
30import Control.Monad.Error.Class (MonadError(..))
30import Control.Monad.Writer.Class (MonadWriter(..))
31import Control.Monad.Writer.Class (MonadWriter(..))
@@ -179,7 +180,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
179-- * Process module imports
180-- * Process module imports
180--
181--
181typeCheckAll :: forall m.
182typeCheckAll :: 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) =>
183 ModuleName ->
184 ModuleName ->
184 [DeclarationRef] ->
185 [DeclarationRef] ->
185 [Declaration] ->
186 [Declaration] ->
@@ -335,7 +336,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
335-- required by exported members are also exported.
336-- required by exported members are also exported.
336--
337--
337typeCheckModule :: forall m.
338typeCheckModule :: 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) =>
339 Module ->
340 Module ->
340 m Module
341 m Module
341typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
src/Language/PureScript/TypeChecker/Monad.hs+1−9
@@ -57,14 +57,13 @@ data CheckState = CheckState
57 , checkNextKind :: Int -- ^ The next kind unification variable
57 , checkNextKind :: Int -- ^ The next kind unification variable
58 , checkNextSkolem :: Int -- ^ The next skolem variable
58 , checkNextSkolem :: Int -- ^ The next skolem variable
59 , checkNextSkolemScope :: Int -- ^ The next skolem scope constant
59 , checkNextSkolemScope :: Int -- ^ The next skolem scope constant
60− , checkNextDictName :: Int -- ^ The next type class dictionary name
61 , checkCurrentModule :: Maybe ModuleName -- ^ The current module
60 , checkCurrentModule :: Maybe ModuleName -- ^ The current module
62 , checkSubstitution :: Substitution -- ^ The current substitution
61 , checkSubstitution :: Substitution -- ^ The current substitution
63 }
62 }
64
63
65-- | Create an empty @CheckState@
64-- | Create an empty @CheckState@
66emptyCheckState :: Environment -> CheckState
65emptyCheckState :: 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
68
67
69-- | Unification variables
68-- | Unification variables
70type Unknown = Int
69type Unknown = Int
@@ -202,13 +201,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()
202guardWith _ True = return ()
201guardWith _ True = return ()
203guardWith e False = throwError e
202guardWith e False = throwError e
204
203
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−
212-- | Run a computation in the substitution monad, generating a return value and the final substitution.
204-- | Run a computation in the substitution monad, generating a return value and the final substitution.
213liftUnify ::
205liftUnify ::
214 (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
206 (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−
16{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
18{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
19{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
20
5
6+-- |
7+-- This module implements the type checker
8+--
21module Language.PureScript.TypeChecker.Types (
9module Language.PureScript.TypeChecker.Types (
22 typesOf
10 typesOf
23) where
11) where
@@ -48,6 +36,7 @@ import qualified Data.Map as M
48
36
49import Control.Monad
37import Control.Monad
50import Control.Monad.State.Class (MonadState(..), gets)
38import Control.Monad.State.Class (MonadState(..), gets)
39+import Control.Monad.Supply.Class (MonadSupply)
51import Control.Monad.Error.Class (MonadError(..))
40import Control.Monad.Error.Class (MonadError(..))
52import Control.Monad.Writer.Class (MonadWriter(..))
41import Control.Monad.Writer.Class (MonadWriter(..))
53
42
@@ -72,7 +61,7 @@ import Language.PureScript.Types
72-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
61-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
73-- type class dictionaries and type annotations.
62-- type class dictionaries and type annotations.
74typesOf ::
63typesOf ::
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) =>
76 ModuleName ->
65 ModuleName ->
77 [(Ident, Expr)] ->
66 [(Ident, Expr)] ->
78 m [(Ident, (Expr, Type))]
67 m [(Ident, (Expr, Type))]
@@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do
129 return (untyped, typed, dict, untypedDict)
118 return (untyped, typed, dict, untypedDict)
130
119
131checkTypedBindingGroupElement ::
120checkTypedBindingGroupElement ::
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) =>
133 ModuleName ->
122 ModuleName ->
134 (Ident, (Expr, Type, Bool)) ->
123 (Ident, (Expr, Type, Bool)) ->
135 TypeData ->
124 TypeData ->
@@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
148 return (ident, (val'', ty''))
137 return (ident, (val'', ty''))
149
138
150typeForBindingGroupElement ::
139typeForBindingGroupElement ::
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) =>
152 Bool ->
141 Bool ->
153 (Ident, Expr) ->
142 (Ident, Expr) ->
154 TypeData ->
143 TypeData ->
@@ -218,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
218
207
219-- | Infer a type for a value, rethrowing any error to provide a more useful error message
208-- | Infer a type for a value, rethrowing any error to provide a more useful error message
220infer ::
209infer ::
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) =>
222 Expr ->
211 Expr ->
223 m Expr
212 m Expr
224infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
225
214
226-- | Infer a type for a value
215-- | Infer a type for a value
227infer' ::
216infer' ::
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) =>
229 Expr ->
218 Expr ->
230 m Expr
219 m Expr
231infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
220infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
@@ -312,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
312infer' _ = internalError "Invalid argument to infer"
301infer' _ = internalError "Invalid argument to infer"
313
302
314inferLetBinding ::
303inferLetBinding ::
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) =>
316 [Declaration] ->
305 [Declaration] ->
317 [Declaration] ->
306 [Declaration] ->
318 Expr ->
307 Expr ->
@@ -423,7 +412,7 @@ binderRequiresMonotype _ = True
423
412
424-- | Instantiate polytypes only when necessitated by a binder.
413-- | Instantiate polytypes only when necessitated by a binder.
425instantiateForBinders ::
414instantiateForBinders ::
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) =>
427 [Expr] ->
416 [Expr] ->
428 [CaseAlternative] ->
417 [CaseAlternative] ->
429 m ([Expr], [Type])
418 m ([Expr], [Type])
@@ -440,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
440-- Check the types of the return values in a set of binders in a case statement
429-- Check the types of the return values in a set of binders in a case statement
441--
430--
442checkBinders ::
431checkBinders ::
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) =>
444 [Type] ->
433 [Type] ->
445 Type ->
434 Type ->
446 [CaseAlternative] ->
435 [CaseAlternative] ->
@@ -470,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
470-- Check the type of a value, rethrowing errors to provide a better error message
459-- Check the type of a value, rethrowing errors to provide a better error message
471--
460--
472check ::
461check ::
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) =>
474 Expr ->
463 Expr ->
475 Type ->
464 Type ->
476 m Expr
465 m Expr
@@ -480,7 +469,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
480-- Check the type of a value
469-- Check the type of a value
481--
470--
482check' :: forall m.
471check' :: 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) =>
484 Expr ->
473 Expr ->
485 Type ->
474 Type ->
486 m Expr
475 m Expr
@@ -495,9 +484,8 @@ check' val (ForAll ident ty _) = do
495 val' <- check skVal sk
484 val' <- check skVal sk
496 return $ TypedValue True val' (ForAll ident ty (Just scope))
485 return $ TypedValue True val' (ForAll ident ty (Just scope))
497check' val t@(ConstrainedType constraints ty) = do
486check' val t@(ConstrainedType constraints ty) = do
498− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
487+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->
499− n <- freshDictionaryName
488+ freshIdent ("dict" ++ className)
500− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
501 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
489 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
502 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
490 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
503 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
491 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
@@ -639,7 +627,7 @@ check' val ty = do
639-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
627-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
640--
628--
641checkProperties ::
629checkProperties ::
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) =>
643 Expr ->
631 Expr ->
644 [(String, Expr)] ->
632 [(String, Expr)] ->
645 Type ->
633 Type ->
@@ -671,7 +659,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
671
659
672-- | Check the type of a function application, rethrowing errors to provide a better error message
660-- | Check the type of a function application, rethrowing errors to provide a better error message
673checkFunctionApplication ::
661checkFunctionApplication ::
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) =>
675 Expr ->
663 Expr ->
676 Type ->
664 Type ->
677 Expr ->
665 Expr ->
@@ -683,7 +671,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication
683
671
684-- | Check the type of a function application
672-- | Check the type of a function application
685checkFunctionApplication' ::
673checkFunctionApplication' ::
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) =>
687 Expr ->
675 Expr ->
688 Type ->
676 Type ->
689 Expr ->
677 Expr ->