@@ -48,10 +48,11 @@ import Data.Generics
4848 something, everywhere, mkQ)
4949import Data.Generics.Extras
5050
51−import Language.PureScript.Values
51+import Language.PureScript.Declarations
5252import Language.PureScript.Types
5353import Language.PureScript.Kinds
5454import Language.PureScript.Names
55+import Language.PureScript.TypeClassDictionaries
5556import Language.PureScript.TypeChecker.Monad
5657import Language.PureScript.TypeChecker.Kinds
5758import Language.PureScript.TypeChecker.Synonyms
@@ -163,48 +164,15 @@ unifyRows r1 r2 =
163164typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
164165typesOf mainModuleName moduleName vals = do
165166 tys <- fmap tidyUp . liftUnify $ do
166− let
167− -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
168− es = map isTyped vals
169− -- Filter the typed and untyped declarations
170− typed = filter (isJust . snd . snd) es
171− untyped = filter (isNothing . snd . snd) es
172− -- Make a map of names to typed declarations
173− typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
174− -- Create fresh unification variables for the types of untyped declarations
175− untypedNames <- replicateM (length untyped) fresh
176− let
177− -- Make a map of names to the unification variables of untyped declarations
178− untypedDict = zip (map fst untyped) untypedNames
179− -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
180− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
181− forM es $ \e@(_, (val, _)) -> do
182− -- If the declaration is a function, it has access to other values in the binding group.
183− -- If not, the generated code might fail at runtime since those values might be undefined.
184− let dict' = if isFunction val then dict else M.empty
185− triple@(_, (_, ty)) <- case e of
186− -- Typed declarations
187− (ident, (val', Just (ty, checkType))) -> do
188− -- Kind check
189− kind <- liftCheck $ kindOf moduleName ty
190− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
191− -- Check the type with the new names in scope
192− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
193− val'' <- bindNames dict' $ if checkType
194− then TypedValue True <$> check val' ty' <*> pure ty'
195− else return (TypedValue False val' ty')
196− return (ident, (val'', ty'))
197− -- Untyped declarations
198− (ident, (val', Nothing)) -> do
199− -- Infer the type with the new names in scope
200− TypedValue _ val'' ty <- bindNames dict' $ infer val'
201− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
202− return (ident, (TypedValue True val'' ty, ty))
167+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
168+ forM es $ \e -> do
169+ triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict
203170 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
204171 when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
205172 [eff, a] <- replicateM 2 fresh
206173 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
207174 return triple
175+
208176 forM tys $ \(ident, (val, ty)) -> do
209177 -- Replace type class dictionary placeholders with actual dictionaries
210178 val' <- replaceTypeClassDictionaries moduleName val
@@ -219,6 +187,51 @@ typesOf mainModuleName moduleName vals = do
219187 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
220188 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
221189
190+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])
191+typeDictionaryForBindingGroup moduleName vals = do
192+ let
193+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
194+ es = map isTyped vals
195+ -- Filter the typed and untyped declarations
196+ typed = filter (isJust . snd . snd) es
197+ untyped = filter (isNothing . snd . snd) es
198+ -- Make a map of names to typed declarations
199+ typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
200+
201+ -- Create fresh unification variables for the types of untyped declarations
202+ untypedNames <- replicateM (length untyped) fresh
203+
204+ let
205+ -- Make a map of names to the unification variables of untyped declarations
206+ untypedDict = zip (map fst untyped) untypedNames
207+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
208+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
209+ return (es, dict, untypedDict)
210+
211+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))
212+typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
213+ -- If the declaration is a function, it has access to other values in the binding group.
214+ -- If not, the generated code might fail at runtime since those values might be undefined.
215+ let dict' = if isFunction val then dict else M.empty
216+ case e of
217+ -- Typed declarations
218+ (ident, (val', Just (ty, checkType))) -> do
219+ -- Kind check
220+ kind <- liftCheck $ kindOf moduleName ty
221+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
222+ -- Check the type with the new names in scope
223+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
224+ val'' <- bindNames dict' $ if checkType
225+ then TypedValue True <$> check val' ty' <*> pure ty'
226+ else return (TypedValue False val' ty')
227+ return (ident, (val'', ty'))
228+ -- Untyped declarations
229+ (ident, (val', Nothing)) -> do
230+ -- Infer the type with the new names in scope
231+ TypedValue _ val'' ty <- bindNames dict' $ infer val'
232+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
233+ return (ident, (TypedValue True val'' ty, ty))
234+
222235-- |
223236-- Check if a value introduces a function
224237--
@@ -547,6 +560,9 @@ infer' (IfThenElse cond th el) = do
547560 v3@(TypedValue _ _ t3) <- infer el
548561 t2 =?= t3
549562 return $ TypedValue True (IfThenElse cond' v2 v3) t2
563+infer' (Let ds val) = do
564+ (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
565+ return $ TypedValue True (Let ds' val') valTy
550566infer' (TypedValue checkType val ty) = do
551567 Just moduleName <- checkCurrentModule <$> get
552568 kind <- liftCheck $ kindOf moduleName ty
@@ -556,6 +572,23 @@ infer' (TypedValue checkType val ty) = do
556572 return $ TypedValue True val' ty'
557573infer' _ = error "Invalid argument to infer"
558574
575+inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
576+inferLetBinding seen [] ret j = (,) seen <$> j ret
577+inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do
578+ valTy <- fresh
579+ Just moduleName <- checkCurrentModule <$> get
580+ TypedValue _ val' valTy' <- bindNames (M.singleton (moduleName, ident) (valTy, nameKind)) $ infer val
581+ valTy =?= valTy'
582+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
583+inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
584+ Just moduleName <- checkCurrentModule <$> get
585+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
586+ ds' <- forM es $ \e -> do
587+ (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
588+ return $ (ident, LocalVariable, val')
589+ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
590+inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"
591+
559592-- |
560593-- Infer the type of a property inside a record with a given type
561594--
@@ -784,6 +817,9 @@ check' (Constructor c) ty = do
784817 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
785818 _ <- subsumes Nothing repl ty
786819 return $ TypedValue True (Constructor c) ty
820+check' (Let ds val) ty = do
821+ (ds', val') <- inferLetBinding [] ds val (flip check ty)
822+ return $ TypedValue True (Let ds' val') ty
787823check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
788824
789825-- |