git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Generate typeclass dictionary names
commit3b6c4bd5b4109f05fa9a8a3f7bb82888197b1676 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 16:51 (13 years ago) parent832c829
4 files changed+43−23
compare with golang
unifiedsplit
examples/passing/TypeClasses.purs+9 src/Language/PureScript/Sugar/TypeClasses.hs+21−19 src/Language/PureScript/TypeChecker/Monad.hs+8−1 src/Language/PureScript/TypeChecker/Types.hs+5−3
examples/passing/TypeClasses.purs+9
@@ -27,3 +27,12 @@ class Monad m where
2727instance TypeClasses.Monad Data where
2828 ret = Data
2929 bind (Data a) f = f a
30+
31+data Maybe a = Nothing | Just a
32+
33+instance TypeClasses.Monad Maybe where
34+ ret = Just
35+ bind Nothing _ = Nothing
36+ bind (Just a) f = f a
37+
38+test4 = Just 1 `bind` (\n -> Just (n + 1))
src/Language/PureScript/Sugar/TypeClasses.hs+21−19
@@ -13,7 +13,9 @@
1313-----------------------------------------------------------------------------
1414
1515module Language.PureScript.Sugar.TypeClasses (
16− desugarTypeClasses
16+ desugarTypeClasses,
17+ mkDictionaryValueName,
18+ mkDictionaryEntryName
1719) where
1820
1921import Language.PureScript.Declarations
@@ -47,8 +49,9 @@ desugarDecl mn d@(TypeClassDeclaration name arg members) = do
4749 modify (M.insert (mn, name) (arg, tys))
4850 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
4951desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
50− entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members
51− dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty members
52+ desugared <- lift $ desugarCases members
53+ entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
54+ dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared
5255 return $ d : dictDecl : entries
5356desugarDecl _ other = return [other]
5457
@@ -69,7 +72,7 @@ typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type c
6972
7073typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
7174typeInstanceDictionaryDeclaration mn deps name ty decls = do
72− entryName <- mkDictionaryValueName mn name ty
75+ entryName <- lift $ mkDictionaryValueName mn name ty
7376 memberNames <- mapM memberToNameAndValue decls
7477 return $ ExternDeclaration entryName
7578 (Just (JSFunction (Just entryName)
@@ -84,16 +87,15 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
8487 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
8588
8689typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
87−typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do
90+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do
8891 m <- get
8992 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $
9093 do (arg, members) <- M.lookup (qualify mn name) m
9194 ty' <- lookup (identToString ident) members
9295 return $ replaceTypeVars arg ty ty'
9396 entryName <- mkDictionaryEntryName mn name ty ident
94− [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]
9597 return $ ValueDeclaration entryName [] Nothing
96− (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))
98+ (TypedValue val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
9799typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
98100
99101identToString :: Ident -> String
@@ -111,21 +113,21 @@ quantify ty' = foldr ForAll ty' tyVars
111113 collect (TypeVar v) = [v]
112114 collect _ = []
113115
114−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Desugar Ident
116+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident
115117mkDictionaryValueName mn cl ty = do
116− tyStr <- lift $ typeToString ty
118+ tyStr <- typeToString mn ty
117119 return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
118− where
119− typeToString :: Type -> Either String String
120− typeToString String = return "string"
121− typeToString Number = return "number"
122− typeToString Boolean = return "boolean"
123− typeToString (Array (TypeVar _)) = return "array"
124− typeToString (TypeConstructor ty') = return $ qualifiedToString mn ty'
125− typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'
126− typeToString _ = Left "Type class instance must be of the form T a1 ... an"
120+
121+typeToString :: ModuleName -> Type -> Either String String
122+typeToString _ String = return "string"
123+typeToString _ Number = return "number"
124+typeToString _ Boolean = return "boolean"
125+typeToString _ (Array (TypeVar _)) = return "array"
126+typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
127+typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
128+typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"
127129
128130mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
129131mkDictionaryEntryName mn name ty ident = do
130− Ident dictName <- mkDictionaryValueName mn name ty
132+ Ident dictName <- lift $ mkDictionaryValueName mn name ty
131133 return $ Ident $ dictName ++ "_" ++ identToString ident
src/Language/PureScript/TypeChecker/Monad.hs+8−1
@@ -120,6 +120,7 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types
120120
121121data CheckState = CheckState { checkEnv :: Environment
122122 , checkNextVar :: Int
123+ , checkNextDictName :: Int
123124 }
124125
125126newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
@@ -136,7 +137,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
136137
137138runCheck :: Check a -> Either String (a, Environment)
138139runCheck c = do
139− (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c
140+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c
140141 return (a, checkEnv s)
141142
142143guardWith :: (MonadError e m) => e -> Bool -> m ()
@@ -146,6 +147,12 @@ guardWith e False = throwError e
146147rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
147148rethrow f = flip catchError $ \e -> throwError (f e)
148149
150+freshDictionaryName :: Check Int
151+freshDictionaryName = do
152+ n <- checkNextDictName <$> get
153+ modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
154+ return n
155+
149156newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
150157
151158instance Monoid Substitution where
src/Language/PureScript/TypeChecker/Types.hs+5−3
@@ -633,9 +633,11 @@ check' val (ForAll idents ty) = do
633633 sk <- skolemize idents ty
634634 check val sk
635635check' val (ConstrainedType constraints ty) = do
636− let dictName = Ident "__dict" -- TODO
637− val' <- withTypeClassDictionaries (map (\(className, instanceTy) -> (dictName, [], className, instanceTy)) constraints) $ check val ty
638− return $ Abs (map (\_ -> dictName) constraints) val'
636+ dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
637+ n <- liftCheck freshDictionaryName
638+ return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
639+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> (name, [], className, instanceTy)) dictNames constraints) $ check val ty
640+ return $ Abs dictNames val'
639641check' val u@(TUnknown _) = do
640642 val'@(TypedValue _ ty) <- infer val
641643 -- Don't unify an unknown with an inferred polytype