0f8a6ba · rowtype-yoga/purescript-native

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

Starting work on replacing type class dictionary placeholders

commit0f8a6ba1eeae5493d851eac06babba50ac1dc0f2 authorPhil Freeman <paf31@cantab.net> dateTue 14 Jan 2014, 22:16 (13 years ago) parente8621c9

5 files changed+39−11

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/Pretty/Values.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs+13−1 src/Language/PureScript/TypeChecker/Types.hs+23−7 src/Language/PureScript/Values.hs+1−1

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

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

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

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

9999valueToJs 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"

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

102102

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

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

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

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

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

4242 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"

4444 match _ = Nothing

4545

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

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

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

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

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

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

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

5455 } deriving (Show)

5556

5657emptyEnvironment :: Environment

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

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

5859

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

6061bindNames newNames action = do

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

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

7374 return a

7475

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+

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

7688bindLocalVariables moduleName bindings action =

7789 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 (

2222import Data.List

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

2424import qualified Data.Data as D

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

25+import Data.Generics

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

2627

2728import Language.PureScript.Values

2829import Language.PureScript.Types

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

169170 escapeCheck val ty

170171 return triple

171172 forM_ tys $ skolemEscapeCheck . snd . snd

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

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

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

174+ val' <- replaceTypeClassDictionaries val

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

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

174177

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

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

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

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

180183overTypes f = everywhere (mkT f)

181184

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+

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

183195escapeCheck value ty = do

184196 subst <- substSubst <$> getSubstState

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

319331 ty <- lookupVariable moduleName var

320332 ty' <- replaceAllTypeSynonyms ty

321333 case ty' of

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

334+ ConstrainedType constraints _ -> do

335+ dicts <- getTypeClassDictionaries

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

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

324338infer' (Block ss) = do

325339 ret <- fresh

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

597611 sk <- skolemize idents ty

598612 check val sk

599613check' val (ConstrainedType constraints ty) = do

600− val' <- check val ty

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

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

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

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

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

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

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

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

737752 ty <- expandTypeSynonym name tyArgs

738753 checkFunctionApplication fn ty args ret

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

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

755+ dicts <- getTypeClassDictionaries

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

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

742758 ++ prettyPrintType fnTy

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

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

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

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

7474 | TypedValue Value Type

7575 | 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)

7777

7878data DoNotationElement

7979 = DoNotationValue Value