git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Show (Data a) example
commit65e7c8c9625bb6b3fe9ad921b08909047d70b613 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 16:08 (13 years ago) parentb4d19dc
4 files changed+70−48
compare with golang
unifiedsplit
examples/passing/TypeClasses.purs+7 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/TypeClasses.hs+37−23 src/Language/PureScript/TypeChecker/Types.hs+25−24
examples/passing/TypeClasses.purs+7
@@ -12,3 +12,10 @@ f :: forall a. (TypeClasses.Show a) => a -> String
1212f x = show x
1313
1414test2 = 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
2626import Language.PureScript.Sugar.TypeClasses as S
2727
2828desugar :: [Module] -> Either String [Module]
29−desugar = return . desugarTypeClasses
29+desugar = desugarTypeClasses
3030 >=> rebracket
3131 >=> desugarDo
3232 >=> desugarCasesModule
src/Language/PureScript/Sugar/TypeClasses.hs+37−23
@@ -21,29 +21,34 @@ import Language.PureScript.Names
2121import Language.PureScript.Types
2222import Language.PureScript.Values
2323import Language.PureScript.CodeGen.JS.AST
24+import Language.PureScript.Sugar.CaseDeclarations
2425
2526import qualified Data.Map as M
2627
2728import Control.Applicative
2829import Control.Monad.State
2930import Data.Maybe (fromMaybe)
31+import Data.List (nub)
32+import Data.Generics (mkQ, everything)
3033
3134type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
3235
33−desugarTypeClasses :: [Module] -> [Module]
34−desugarTypeClasses = flip evalState M.empty . mapM desugarModule
36+type Desugar = StateT MemberMap (Either String)
3537
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
3742desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls
3843
39−desugarDecl :: ModuleName -> Declaration -> State MemberMap [Declaration]
44+desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
4045desugarDecl mn d@(TypeClassDeclaration name arg members) = do
4146 let tys = map memberToNameAndType members
4247 modify (M.insert (mn, name) (arg, tys))
4348 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
4449desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
4550 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
4752desugarDecl _ other = return [other]
4853
4954memberToNameAndType :: Declaration -> (String, Type)
@@ -61,52 +66,61 @@ typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
6166 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
6267typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
6368
64−typeInstanceDictionaryDeclaration :: [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration
65−typeInstanceDictionaryDeclaration deps name ty decls =
66− ExternDeclaration (mkDictionaryValueName name ty)
67− (Just (JSFunction (Just (mkDictionaryValueName name ty))
69+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration
70+typeInstanceDictionaryDeclaration mn deps name ty decls =
71+ ExternDeclaration (mkDictionaryValueName mn name ty)
72+ (Just (JSFunction (Just (mkDictionaryValueName mn name ty))
6873 (map (\n -> Ident ('_' : show n)) [1..length deps])
6974 (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)))
7176 where
7277 memberToNameAndValue :: Declaration -> (String, JS)
7378 memberToNameAndValue (ValueDeclaration ident _ _ _) =
74− (identToString ident, let dict = JSVar $ mkDictionaryEntryName name ty ident
79+ (identToString ident, let dict = JSVar $ mkDictionaryEntryName mn name ty ident
7580 in if null deps then dict
7681 else JSApp dict (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
7782 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
7883
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
8085typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do
8186 m <- get
8287 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $
8388 do (arg, members) <- M.lookup (qualify mn name) m
8489 ty' <- lookup (identToString ident) members
8590 return $ replaceTypeVars arg ty ty'
86− return $ ValueDeclaration (mkDictionaryEntryName name ty ident) binders grd
87− (TypedValue val (if null deps then valTy else ConstrainedType deps valTy))
91+ entryName = mkDictionaryEntryName mn name ty ident
92+ [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]
93+ return $ ValueDeclaration entryName [] Nothing
94+ (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))
8895typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
8996
9097identToString :: Ident -> String
9198identToString (Ident s) = s
9299identToString (Op _) = error "TODO: Unsupported type class instance name"
93100
94−qualifiedToString :: Qualified ProperName -> String
95−qualifiedToString (Qualified Nothing _) = error "TODO: handle unqualified instances"
96−qualifiedToString (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn
101+qualifiedToString :: ModuleName -> Qualified ProperName -> String
102+qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) 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 _ = []
97111
98−mkDictionaryValueName :: Qualified ProperName -> Type -> Ident
99−mkDictionaryValueName cl ty = Ident $ "__" ++ qualifiedToString cl ++ "_" ++ typeToString ty
112+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Ident
113+mkDictionaryValueName mn cl ty = Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ typeToString ty
100114 where
101115 typeToString :: Type -> String
102116 typeToString String = "string"
103117 typeToString Number = "number"
104118 typeToString Boolean = "boolean"
105119 typeToString (Array (TypeVar _)) = "array"
106− typeToString (TypeConstructor ty') = qualifiedToString ty'
120+ typeToString (TypeConstructor ty') = qualifiedToString mn ty'
107121 typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'
108122 typeToString _ = error "TODO: Type class instance must be of the form T a1 ... an"
109123
110−mkDictionaryEntryName :: Qualified ProperName -> Type -> Ident -> Ident
111−mkDictionaryEntryName name ty ident = let Ident dictName = mkDictionaryValueName name ty
112− in Ident $ dictName ++ "_" ++ identToString ident
124+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Ident
125+mkDictionaryEntryName mn name ty ident = let Ident dictName = mkDictionaryValueName mn name ty
126+ in Ident $ dictName ++ "_" ++ identToString ident
src/Language/PureScript/TypeChecker/Types.hs+25−24
@@ -171,7 +171,7 @@ typesOf moduleName vals = do
171171 return triple
172172 forM_ tys $ skolemEscapeCheck . snd . snd
173173 forM tys $ \(ident, (val, ty)) -> do
174− val' <- replaceTypeClassDictionaries val
174+ val' <- replaceTypeClassDictionaries moduleName val
175175 return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
176176 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
177177
@@ -182,35 +182,36 @@ isTyped (name, value) = (name, (value, Nothing))
182182overTypes :: (Type -> Type) -> Value -> Value
183183overTypes f = everywhere (mkT f)
184184
185−replaceTypeClassDictionaries :: Value -> Check Value
186−replaceTypeClassDictionaries = everywhereM (mkM go)
185+replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
186+replaceTypeClassDictionaries mn = everywhereM (mkM go)
187187 where
188− go (TypeClassDictionary constraint dicts) = entails dicts constraint
188+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
189189 go other = return other
190190
191−entails :: [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)] -> (Qualified ProperName, Type) -> Check Value
192−entails context goal =
193− case go goal of
191+entails :: ModuleName -> [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)] -> (Qualified ProperName, Type) -> Check Value
192+entails moduleName context goal = do
193+ env <- getEnv
194+ case go env goal of
194195 [] -> throwError $ "No type class instance for " ++ show goal ++ " in context " ++ show context
195196 (dict : _) -> return dict
196197 where
197− go (className, ty) = [ App (Var (Qualified Nothing fnName)) args
198− | (fnName, subgoals, className', ty') <- context
199− , className == className'
200− , subst <- maybeToList $ typeHeadsAreEqual ty ty'
201− , args <- forM (replaceAllTypeVars subst subgoals) go ]
202− typeHeadsAreEqual :: Type -> Type -> Maybe [(String, Type)]
203− typeHeadsAreEqual String String = Just []
204− typeHeadsAreEqual Number Number = Just []
205− typeHeadsAreEqual Boolean Boolean = Just []
206− typeHeadsAreEqual (Skolem s1) (Skolem s2) | s1 == s2 = Just []
207− typeHeadsAreEqual (Array ty1) (Array ty2) = typeHeadsAreEqual ty1 ty2
208− typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
209− typeHeadsAreEqual (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = do
210− m <- typeHeadsAreEqual h1 h2
211− return $ (v, arg) : m
212− typeHeadsAreEqual t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual t2 t1
213− typeHeadsAreEqual _ _ = Nothing
198+ go env (className, ty) =
199+ [ App (Var (Qualified Nothing fnName)) args
200+ | (fnName, subgoals, className', ty') <- context
201+ , className == className'
202+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty ty'
203+ , args <- forM (replaceAllTypeVars subst subgoals) (go env) ]
204+
205+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
206+typeHeadsAreEqual _ _ String String = Just []
207+typeHeadsAreEqual _ _ Number Number = Just []
208+typeHeadsAreEqual _ _ Boolean Boolean = Just []
209+typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
210+typeHeadsAreEqual m e (Array ty1) (Array ty2) = typeHeadsAreEqual m e ty1 ty2
211+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
212+typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
213+typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
214+typeHeadsAreEqual _ _ _ _ = Nothing
214215
215216escapeCheck :: Value -> Type -> Subst ()
216217escapeCheck value ty = do