@@ -42,10 +42,11 @@ module Language.PureScript.TypeChecker.Types (
4242-}
4343
4444import Data.List
45−import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
45+import Data.Maybe (maybeToList, fromMaybe)
4646import Data.Function (on)
4747import Data.Ord (comparing)
4848import Data.Monoid
49+import Data.Either (lefts, rights)
4950
5051import Language.PureScript.Declarations
5152import Language.PureScript.Types
@@ -171,14 +172,16 @@ unifyRows r1 r2 =
171172typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
172173typesOf mainModuleName moduleName vals = do
173174 tys <- fmap tidyUp . liftUnify $ do
174− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
175− forM es $ \e -> do
176− triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict
177− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
178− when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
179− [eff, a] <- replicateM 2 fresh
180− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
175+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
176+ ds1 <- parU typed $ \e -> do
177+ triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
178+ checkMain (fst e) ty
181179 return triple
180+ ds2 <- forM untyped $ \e -> do
181+ triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
182+ checkMain (fst e) ty
183+ return triple
184+ return $ ds1 ++ ds2
182185
183186 forM tys $ \(ident, (val, ty)) -> do
184187 -- Replace type class dictionary placeholders with actual dictionaries
@@ -193,17 +196,25 @@ typesOf mainModuleName moduleName vals = do
193196 where
194197 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
195198 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
199+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
200+ checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
201+ [eff, a] <- replicateM 2 fresh
202+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
203+
204+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
205+
206+type UntypedData = [(Ident, Type)]
196207
197−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
208+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
198209typeDictionaryForBindingGroup moduleName vals = do
199210 let
200211 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
201212 es = map isTyped vals
202213 -- Filter the typed and untyped declarations
203− typed = filter (isJust . snd . snd) es
204− untyped = filter (isNothing . snd . snd) es
214+ untyped = lefts es
215+ typed = rights es
205216 -- Make a map of names to typed declarations
206− typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
217+ typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
207218
208219 -- Create fresh unification variables for the types of untyped declarations
209220 untypedNames <- replicateM (length untyped) fresh
@@ -213,37 +224,33 @@ typeDictionaryForBindingGroup moduleName vals = do
213224 untypedDict = zip (map fst untyped) untypedNames
214225 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
215226 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
216− return (es, dict, untypedDict)
217−
218−typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))
219−typeForBindingGroupElement moduleName el dict untypedDict =
220− -- If the declaration is a function, it has access to other values in the binding group.
221− -- If not, the generated code might fail at runtime since those values might be undefined.
222− case el of
223− -- Typed declarations
224− (ident, (val', Just (ty, checkType))) -> do
225− -- Kind check
226− kind <- liftCheck $ kindOf moduleName ty
227− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
228− -- Check the type with the new names in scope
229− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
230− val'' <- if checkType
231− then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
232− else return (TypedValue False val' ty')
233− return (ident, (val'', ty'))
234− -- Untyped declarations
235− (ident, (val', Nothing)) -> do
236− -- Infer the type with the new names in scope
237− TypedValue _ val'' ty <- bindNames dict $ infer val'
238− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
239− return (ident, (TypedValue True val'' ty, ty))
227+ return (untyped, typed, dict, untypedDict)
228+
229+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
230+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do
231+ -- Kind check
232+ kind <- liftCheck $ kindOf moduleName ty
233+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
234+ -- Check the type with the new names in scope
235+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
236+ val'' <- if checkType
237+ then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
238+ else return (TypedValue False val' ty')
239+ return (ident, (val'', ty'))
240+
241+typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))
242+typeForBindingGroupElement (ident, val) dict untypedDict = do
243+ -- Infer the type with the new names in scope
244+ TypedValue _ val' ty <- bindNames dict $ infer val
245+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
246+ return (ident, (TypedValue True val' ty, ty))
240247
241248-- |
242249-- Check if a value contains a type annotation
243250--
244−isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))
245−isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
246−isTyped (name, value) = (name, (value, Nothing))
251+isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))
252+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
253+isTyped (name, value) = Left (name, value)
247254
248255-- |
249256-- Map a function over type annotations appearing inside a value
@@ -692,10 +699,10 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret
692699 bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
693700inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
694701 Just moduleName <- checkCurrentModule <$> get
695− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
696− ds' <- forM es $ \e -> do
697− (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
698− return $ (ident, LocalVariable, val')
702+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
703+ ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
704+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
705+ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
699706 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
700707inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
701708 ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
@@ -1135,3 +1142,5 @@ meet e1 e2 t1 t2 = do
11351142
11361143
11371144
1145+
1146+