0f8a6ba · rowtype-yoga/purescript-native

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

on golang help sign in

Starting work on replacing type class dictionary placeholders

0f8a6baPhil Freeman13 years ago

src/Language/PureScript/CodeGen/JS.hs+1−1

compare with golang

unifiedsplit

@@ -97,7 +97,7 @@ valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

97valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

98valueToJs _ m e (Var ident) = varToJs m e ident

99valueToJs opts m e (TypedValue val _) = valueToJs opts m e val

100−valueToJs _ _ _ (TypeClassDictionary _) = error "Type class dictionary was not replaced"

100+valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

101valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

102

103runtimeTypeChecks :: [Ident] -> Type -> [JS]

src/Language/PureScript/Pretty/Values.hs+1−1

@@ -40,7 +40,7 @@ literals = mkPattern match

40 match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

42 match (Var ident) = Just $ show ident

43− match (TypeClassDictionary _) = error "Type class dictionary was not replaced"

43+ match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

44 match _ = Nothing

46prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

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

@@ -51,10 +51,11 @@ data Environment = Environment

51 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

52 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

53 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

54+ , typeClassDictionaries :: [(Ident, Qualified ProperName, Type)]

54 } deriving (Show)

55 } deriving (Show)

56emptyEnvironment :: Environment

57emptyEnvironment :: Environment

57−emptyEnvironment = Environment M.empty M.empty M.empty M.empty

58+emptyEnvironment = Environment M.empty M.empty M.empty M.empty []

59bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

60bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

60bindNames newNames action = do

61bindNames newNames action = do

@@ -72,6 +73,17 @@ bindTypes newNames action = do

72 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

73 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

73 return a

74 return a

76+withTypeClassDictionaries :: (MonadState CheckState m) => [(Ident, Qualified ProperName, Type)] -> m a -> m a

77+withTypeClassDictionaries entries action = do

78+ orig <- get

79+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

80+ a <- action

81+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

82+ return a

83+

84+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [(Ident, Qualified ProperName, Type)]

85+getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

86+

75bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

87bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

76bindLocalVariables moduleName bindings action =

88bindLocalVariables moduleName bindings action =

77 bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

89 bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

src/Language/PureScript/TypeChecker/Types.hs+23−7

@@ -22,7 +22,8 @@ module Language.PureScript.TypeChecker.Types (

22import Data.List

23import Data.Maybe (isNothing, isJust, fromMaybe)

24import qualified Data.Data as D

25+import Data.Generics

25−import Data.Generics (everything, mkT, something, everywhere, mkQ)

26+ (mkM, everywhereM, everything, mkT, something, everywhere, mkQ)

27import Language.PureScript.Values

28import Language.PureScript.Values

28import Language.PureScript.Types

29import Language.PureScript.Types

@@ -169,8 +170,10 @@ typesOf moduleName vals = do

169 escapeCheck val ty

170 escapeCheck val ty

170 return triple

171 return triple

171 forM_ tys $ skolemEscapeCheck . snd . snd

172 forM_ tys $ skolemEscapeCheck . snd . snd

173+ forM tys $ \(ident, (val, ty)) -> do

174+ val' <- replaceTypeClassDictionaries val

172− return $ map (\(ident, (val, ty)) -> ( ident, ( overTypes (desaturateAllTypeSynonyms . setifyAll) val

175+ return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'

173− , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))) tys

176+ , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

174

177

175isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))

178isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))

176isTyped (name, TypedValue value ty) = (name, (value, Just ty))

179isTyped (name, TypedValue value ty) = (name, (value, Just ty))

@@ -179,6 +182,15 @@ isTyped (name, value) = (name, (value, Nothing))

179overTypes :: (Type -> Type) -> Value -> Value

182overTypes :: (Type -> Type) -> Value -> Value

180overTypes f = everywhere (mkT f)

183overTypes f = everywhere (mkT f)

181

184

185+replaceTypeClassDictionaries :: Value -> Check Value

186+replaceTypeClassDictionaries = everywhereM (mkM go)

187+ where

188+ go (TypeClassDictionary constraint dicts) = entails dicts constraint

189+ go other = return other

190+

191+entails :: [(Ident, Qualified ProperName, Type)] -> (Qualified ProperName, Type) -> Check Value

192+entails _ _ = return $ Var $ Qualified Nothing $ Ident "placeholder" -- TODO

193+

182escapeCheck :: Value -> Type -> Subst ()

194escapeCheck :: Value -> Type -> Subst ()

183escapeCheck value ty = do

195escapeCheck value ty = do

184 subst <- substSubst <$> getSubstState

196 subst <- substSubst <$> getSubstState

@@ -319,7 +331,9 @@ infer' (Var var) = do

319 ty <- lookupVariable moduleName var

331 ty <- lookupVariable moduleName var

320 ty' <- replaceAllTypeSynonyms ty

332 ty' <- replaceAllTypeSynonyms ty

321 case ty' of

333 case ty' of

334+ ConstrainedType constraints _ -> do

335+ dicts <- getTypeClassDictionaries

322− ConstrainedType constraints _ -> return $ TypedValue (App (Var var) [TypeClassDictionary constraints]) ty'

336+ return $ TypedValue (App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

323 _ -> return $ TypedValue (Var var) ty'

337 _ -> return $ TypedValue (Var var) ty'

324infer' (Block ss) = do

338infer' (Block ss) = do

325 ret <- fresh

339 ret <- fresh

@@ -597,8 +611,9 @@ check' val (ForAll idents ty) = do

597 sk <- skolemize idents ty

611 sk <- skolemize idents ty

598 check val sk

612 check val sk

599check' val (ConstrainedType constraints ty) = do

613check' val (ConstrainedType constraints ty) = do

600− val' <- check val ty

614+ let dictName = Ident "__dict" -- TODO

615+ val' <- withTypeClassDictionaries (map (\(className, instanceTy) -> (dictName, className, instanceTy)) constraints) $ check val ty

601− return $ Abs (map (\_ -> Ident "__dict") constraints) val'

616+ return $ Abs (map (\_ -> dictName) constraints) val'

602check' val u@(TUnknown _) = do

617check' val u@(TUnknown _) = do

603 val'@(TypedValue _ ty) <- infer val

618 val'@(TypedValue _ ty) <- infer val

604 -- Don't unify an unknown with an inferred polytype

619 -- Don't unify an unknown with an inferred polytype

@@ -737,7 +752,8 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

737 ty <- expandTypeSynonym name tyArgs

752 ty <- expandTypeSynonym name tyArgs

738 checkFunctionApplication fn ty args ret

753 checkFunctionApplication fn ty args ret

739checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

754checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

755+ dicts <- getTypeClassDictionaries

740− checkFunctionApplication' (App fn [TypeClassDictionary constraints]) fnTy args ret

756+ checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy args ret

741checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

757checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

742 ++ prettyPrintType fnTy

758 ++ prettyPrintType fnTy

743 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

759 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

src/Language/PureScript/Values.hs+1−1

@@ -73,7 +73,7 @@ data Value

73 | Case [Value] [([Binder], Maybe Guard, Value)]

74 | TypedValue Value Type

75 | Do Value [DoNotationElement]

76− | TypeClassDictionary [(Qualified ProperName, Type)] deriving (Show, Data, Typeable)

76+ | TypeClassDictionary (Qualified ProperName, Type) [(Ident, Qualified ProperName, Type)] deriving (Show, Data, Typeable)

78data DoNotationElement

79 = DoNotationValue Value