65e7c8c · rowtype-yoga/purescript-native

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

on golang help sign in

Show (Data a) example

65e7c8cPhil Freeman13 years ago

examples/passing/TypeClasses.purs+7

compare with golang

unifiedsplit

@@ -12,3 +12,10 @@ f :: forall a. (TypeClasses.Show a) => a -> String

12f x = show x

14test2 = f "testing"

15+

16+data Data a = Data a

17+

18+instance (TypeClasses.Show a) => TypeClasses.Show (Data a) where

19+ show (Data a) = "Data (" ++ show a ++ ")"

20+

21+test3 = show (Data "testing")

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

@@ -26,7 +26,7 @@ import Language.PureScript.Sugar.BindingGroups as S

26import Language.PureScript.Sugar.TypeClasses as S

28desugar :: [Module] -> Either String [Module]

29−desugar = return . desugarTypeClasses

29+desugar = desugarTypeClasses

30 >=> rebracket

31 >=> desugarDo

32 >=> desugarCasesModule

src/Language/PureScript/Sugar/TypeClasses.hs+37−23

@@ -21,29 +21,34 @@ import Language.PureScript.Names

21import Language.PureScript.Types

22import Language.PureScript.Values

23import Language.PureScript.CodeGen.JS.AST

24+import Language.PureScript.Sugar.CaseDeclarations

25import qualified Data.Map as M

26import qualified Data.Map as M

27import Control.Applicative

28import Control.Applicative

28import Control.Monad.State

29import Control.Monad.State

29import Data.Maybe (fromMaybe)

30import Data.Maybe (fromMaybe)

31+import Data.List (nub)

32+import Data.Generics (mkQ, everything)

31type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])

34type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])

33−desugarTypeClasses :: [Module] -> [Module]

36+type Desugar = StateT MemberMap (Either String)

34−desugarTypeClasses = flip evalState M.empty . mapM desugarModule

36−desugarModule :: Module -> State MemberMap Module

38+desugarTypeClasses :: [Module] -> Either String [Module]

39+desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

40+

41+desugarModule :: Module -> Desugar Module

37desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

42desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

39−desugarDecl :: ModuleName -> Declaration -> State MemberMap [Declaration]

44+desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

40desugarDecl mn d@(TypeClassDeclaration name arg members) = do

45desugarDecl mn d@(TypeClassDeclaration name arg members) = do

41 let tys = map memberToNameAndType members

46 let tys = map memberToNameAndType members

42 modify (M.insert (mn, name) (arg, tys))

47 modify (M.insert (mn, name) (arg, tys))

43 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

48 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

44desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

49desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

45 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members

50 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members

46− return $ d : typeInstanceDictionaryDeclaration deps name ty members : entries

51+ return $ d : typeInstanceDictionaryDeclaration mn deps name ty members : entries

47desugarDecl _ other = return [other]

52desugarDecl _ other = return [other]

49memberToNameAndType :: Declaration -> (String, Type)

54memberToNameAndType :: Declaration -> (String, Type)

@@ -61,52 +66,61 @@ typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

61 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))

66 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))

62typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

67typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

64−typeInstanceDictionaryDeclaration :: [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration

69+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration

65−typeInstanceDictionaryDeclaration deps name ty decls =

70+typeInstanceDictionaryDeclaration mn deps name ty decls =

66− ExternDeclaration (mkDictionaryValueName name ty)

71+ ExternDeclaration (mkDictionaryValueName mn name ty)

67− (Just (JSFunction (Just (mkDictionaryValueName name ty))

72+ (Just (JSFunction (Just (mkDictionaryValueName mn name ty))

68 (map (\n -> Ident ('_' : show n)) [1..length deps])

73 (map (\n -> Ident ('_' : show n)) [1..length deps])

69 (JSBlock [JSReturn (JSObjectLiteral $ map memberToNameAndValue decls)])))

74 (JSBlock [JSReturn (JSObjectLiteral $ map memberToNameAndValue decls)])))

70− (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty))

75+ (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))

71 where

76 where

72 memberToNameAndValue :: Declaration -> (String, JS)

77 memberToNameAndValue :: Declaration -> (String, JS)

73 memberToNameAndValue (ValueDeclaration ident _ _ _) =

78 memberToNameAndValue (ValueDeclaration ident _ _ _) =

74− (identToString ident, let dict = JSVar $ mkDictionaryEntryName name ty ident

79+ (identToString ident, let dict = JSVar $ mkDictionaryEntryName mn name ty ident

75 in if null deps then dict

80 in if null deps then dict

76 else JSApp dict (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))

81 else JSApp dict (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))

77 memberToNameAndValue _ = error "Invalid declaration in type instance definition"

82 memberToNameAndValue _ = error "Invalid declaration in type instance definition"

79−typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> State MemberMap Declaration

84+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

80typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do

85typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do

81 m <- get

86 m <- get

82 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $

87 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $

83 do (arg, members) <- M.lookup (qualify mn name) m

88 do (arg, members) <- M.lookup (qualify mn name) m

84 ty' <- lookup (identToString ident) members

89 ty' <- lookup (identToString ident) members

85 return $ replaceTypeVars arg ty ty'

90 return $ replaceTypeVars arg ty ty'

86− return $ ValueDeclaration (mkDictionaryEntryName name ty ident) binders grd

91+ entryName = mkDictionaryEntryName mn name ty ident

92+ [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]

93+ return $ ValueDeclaration entryName [] Nothing

87− (TypedValue val (if null deps then valTy else ConstrainedType deps valTy))

94+ (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))

88typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

95typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

90identToString :: Ident -> String

97identToString :: Ident -> String

91identToString (Ident s) = s

98identToString (Ident s) = s

92identToString (Op _) = error "TODO: Unsupported type class instance name"

99identToString (Op _) = error "TODO: Unsupported type class instance name"

100

94−qualifiedToString :: Qualified ProperName -> String

101+qualifiedToString :: ModuleName -> Qualified ProperName -> String

95−qualifiedToString (Qualified Nothing _) = error "TODO: handle unqualified instances"

102+qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

96−qualifiedToString (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn

103+qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn

104+

105+quantify :: Type -> Type

106+quantify ty' = foldr ForAll ty' tyVars

107+ where

108+ tyVars = nub $ everything (++) (mkQ [] collect) ty'

109+ collect (TypeVar v) = [v]

110+ collect _ = []

111

98−mkDictionaryValueName :: Qualified ProperName -> Type -> Ident

112+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Ident

99−mkDictionaryValueName cl ty = Ident $ "__" ++ qualifiedToString cl ++ "_" ++ typeToString ty

113+mkDictionaryValueName mn cl ty = Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ typeToString ty

100 where

114 where

101 typeToString :: Type -> String

115 typeToString :: Type -> String

102 typeToString String = "string"

116 typeToString String = "string"

103 typeToString Number = "number"

117 typeToString Number = "number"

104 typeToString Boolean = "boolean"

118 typeToString Boolean = "boolean"

105 typeToString (Array (TypeVar _)) = "array"

119 typeToString (Array (TypeVar _)) = "array"

106− typeToString (TypeConstructor ty') = qualifiedToString ty'

120+ typeToString (TypeConstructor ty') = qualifiedToString mn ty'

107 typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'

121 typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'

108 typeToString _ = error "TODO: Type class instance must be of the form T a1 ... an"

122 typeToString _ = error "TODO: Type class instance must be of the form T a1 ... an"

109

123

110−mkDictionaryEntryName :: Qualified ProperName -> Type -> Ident -> Ident

124+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Ident

111−mkDictionaryEntryName name ty ident = let Ident dictName = mkDictionaryValueName name ty

125+mkDictionaryEntryName mn name ty ident = let Ident dictName = mkDictionaryValueName mn name ty

112− in Ident $ dictName ++ "_" ++ identToString ident

126+ in Ident $ dictName ++ "_" ++ identToString ident

src/Language/PureScript/TypeChecker/Types.hs+25−24

@@ -171,7 +171,7 @@ typesOf moduleName vals = do

171 return triple

172 forM_ tys $ skolemEscapeCheck . snd . snd

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

174− val' <- replaceTypeClassDictionaries val

174+ val' <- replaceTypeClassDictionaries moduleName val

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

176 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

177

@@ -182,35 +182,36 @@ isTyped (name, value) = (name, (value, Nothing))

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

183overTypes f = everywhere (mkT f)

184

185−replaceTypeClassDictionaries :: Value -> Check Value

185+replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

186−replaceTypeClassDictionaries = everywhereM (mkM go)

186+replaceTypeClassDictionaries mn = everywhereM (mkM go)

187 where

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

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

189 go other = return other

190

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

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

192−entails context goal =

192+entails moduleName context goal = do

193+ env <- getEnv

193− case go goal of

194+ case go env goal of

194 [] -> throwError $ "No type class instance for " ++ show goal ++ " in context " ++ show context

195 [] -> throwError $ "No type class instance for " ++ show goal ++ " in context " ++ show context

195 (dict : _) -> return dict

196 (dict : _) -> return dict

196 where

197 where

198+ go env (className, ty) =

197− go (className, ty) = [ App (Var (Qualified Nothing fnName)) args

199+ [ App (Var (Qualified Nothing fnName)) args

198− | (fnName, subgoals, className', ty') <- context

200+ | (fnName, subgoals, className', ty') <- context

199− , className == className'

201+ , className == className'

200− , subst <- maybeToList $ typeHeadsAreEqual ty ty'

202+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty ty'

201− , args <- forM (replaceAllTypeVars subst subgoals) go ]

203+ , args <- forM (replaceAllTypeVars subst subgoals) (go env) ]

204+

202− typeHeadsAreEqual :: Type -> Type -> Maybe [(String, Type)]

205+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

203− typeHeadsAreEqual String String = Just []

206+typeHeadsAreEqual _ _ String String = Just []

204− typeHeadsAreEqual Number Number = Just []

207+typeHeadsAreEqual _ _ Number Number = Just []

205− typeHeadsAreEqual Boolean Boolean = Just []

208+typeHeadsAreEqual _ _ Boolean Boolean = Just []

206− typeHeadsAreEqual (Skolem s1) (Skolem s2) | s1 == s2 = Just []

209+typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []

207− typeHeadsAreEqual (Array ty1) (Array ty2) = typeHeadsAreEqual ty1 ty2

210+typeHeadsAreEqual m e (Array ty1) (Array ty2) = typeHeadsAreEqual m e ty1 ty2

208− typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

211+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []

209− typeHeadsAreEqual (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = do

212+typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

210− m <- typeHeadsAreEqual h1 h2

211− return $ (v, arg) : m

212− typeHeadsAreEqual t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual t2 t1

213+typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

213− typeHeadsAreEqual _ _ = Nothing

214+typeHeadsAreEqual _ _ _ _ = Nothing

214

215

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

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

216escapeCheck value ty = do

217escapeCheck value ty = do