b4d19dc · rowtype-yoga/purescript-native

examples/passing/TypeClasses.purs+1−1

compare with golang

unifiedsplit

@@ -8,7 +8,7 @@ instance TypeClasses.Show String where

8

9test1 = show "testing"

10

11−f :: forall a. (Show a) => a -> String

11+f :: forall a. (TypeClasses.Show a) => a -> String

12f x = show x

13

14test2 = f "testing"

src/Language/PureScript/Sugar/TypeClasses.hs+4−4

@@ -37,13 +37,13 @@ desugarModule :: Module -> State MemberMap Module

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

38

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

40−desugarDecl mn (TypeClassDeclaration name arg members) = do

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

41 let tys = map memberToNameAndType members

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

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

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

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

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

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

46− return $ typeInstanceDictionaryDeclaration deps name ty members : entries

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

47desugarDecl _ other = return [other]

48

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

src/Language/PureScript/TypeChecker.hs+3−2

@@ -200,8 +200,9 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

200typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

201 ds <- typeCheckAll moduleName rest

202 return $ d : ds

203−typeCheckAll moduleName (d@(TypeInstanceDeclaration _ _ _ _) : rest) = do

203+typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

204+ ds <- withTypeClassDictionaries [(Ident "__TODO", deps, className, ty)] $

204− ds <- typeCheckAll moduleName rest

205+ typeCheckAll moduleName rest

205 return $ d : ds

206 return $ d : ds

206

207

207qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

208qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

src/Language/PureScript/TypeChecker/Monad.hs+3−3

@@ -51,7 +51,7 @@ 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+ , typeClassDictionaries :: [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)]

55 } deriving (Show)

56

57emptyEnvironment :: Environment

@@ -73,7 +73,7 @@ bindTypes newNames action = do

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

74 return a

75

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

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

77withTypeClassDictionaries entries action = do

78 orig <- get

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

@@ -81,7 +81,7 @@ withTypeClassDictionaries entries action = do

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

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

85getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

86

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

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

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

20) where

21

22import Data.List

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

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

24import qualified Data.Data as D

25import Data.Generics

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

@@ -188,8 +188,29 @@ replaceTypeClassDictionaries = everywhereM (mkM go)

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

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

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

192+entails context goal =

193+ case go goal of

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

195+ (dict : _) -> return dict

196+ 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

193

214

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

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

195escapeCheck value ty = do

216escapeCheck value ty = do

@@ -612,7 +633,7 @@ check' val (ForAll idents ty) = do

612 check val sk

633 check val sk

613check' val (ConstrainedType constraints ty) = do

634check' val (ConstrainedType constraints ty) = do

614 let dictName = Ident "__dict" -- TODO

635 let dictName = Ident "__dict" -- TODO

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

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

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

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

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

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

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

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

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) [(Ident, Qualified ProperName, Type)] deriving (Show, Data, Typeable)

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

77

78data DoNotationElement

79 = DoNotationValue Value