f0eb3e1 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix kind checking, code gen for dictionaries

f0eb3e1Phil Freeman13 years ago

examples/passing/TypeClasses.purs+2

compare with golang

unifiedsplit

@@ -5,3 +5,5 @@ class Show a where

6instance TypeClasses.Show String where

7 show s = s

9+test = show "testing"

src/Language/PureScript/Pretty/Types.hs+1

@@ -37,6 +37,7 @@ typeLiterals = mkPattern match

37 match (TypeConstructor ctor) = Just $ show ctor

38 match (TUnknown (Unknown u)) = Just $ 'u' : show u

39 match (Skolem s) = Just $ 's' : show s

40+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty

40 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

41 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

41 match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

42 match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

42 match REmpty = Just $ prettyPrintRow REmpty

43 match REmpty = Just $ prettyPrintRow REmpty

src/Language/PureScript/Sugar/TypeClasses.hs+14−9

@@ -28,7 +28,7 @@ import Control.Applicative

28import Control.Monad.State

29import Data.Maybe (fromMaybe)

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

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

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

34desugarTypeClasses = flip evalState M.empty . mapM desugarModule

@@ -39,7 +39,7 @@ desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl

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

40desugarDecl mn (TypeClassDeclaration name arg members) = do

41 let tys = map memberToNameAndType members

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

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

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

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

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

@@ -57,29 +57,34 @@ typeClassDictionaryDeclaration name arg members =

57typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

58typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

59 ExternDeclaration ident

60− (Just (JSFunction (Just (Ident arg)) [Ident "dict"] (JSReturn (JSAccessor arg (JSVar (Ident "dict"))))))

60+ (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor arg (JSVar (Ident "dict")))])))

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

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

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

65typeInstanceDictionaryDeclaration deps name ty decls =

66 ExternDeclaration (mkDictionaryValueName name ty)

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

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

67− (Just (JSObjectLiteral $ map memberToNameAndValue decls))

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

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

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

69 where

71 where

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

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

71 memberToNameAndValue (ValueDeclaration ident _ _ _) =

73 memberToNameAndValue (ValueDeclaration ident _ _ _) =

72− (identToString ident, JSVar $ mkDictionaryEntryName name ty ident)

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

75+ in if null deps then dict

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

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

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

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

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

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

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

77 m <- get

81 m <- get

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

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

79− members <- M.lookup (qualify mn name) m

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

80− lookup (identToString ident) members

84+ ty' <- lookup (identToString ident) members

85+ return $ replaceTypeVars arg ty ty'

81 return $ ValueDeclaration (mkDictionaryEntryName name ty ident) binders grd

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

82− (TypedValue val (ConstrainedType deps valTy))

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

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

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

85identToString :: Ident -> String

90identToString :: Ident -> String

src/Language/PureScript/TypeChecker/Kinds.hs+5

@@ -136,4 +136,9 @@ infer (RCons _ ty row) = do

136 k2 <- infer row

137 k2 ~~ Row k1

138 return $ Row k1

139+infer (ConstrainedType deps ty) = do

140+ mapM_ (infer . snd) deps

141+ k <- infer ty

142+ k ~~ Star

143+ return Star

139infer _ = error "Invalid argument to infer"

144infer _ = error "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Types.hs+1−9

@@ -23,7 +23,7 @@ import Data.List

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

24import qualified Data.Data as D

25import Data.Generics

26− (mkT, something, everywhere, everywhereBut, mkQ)

26+ (mkT, something, everywhere, mkQ)

28import Language.PureScript.Values

29import Language.PureScript.Types

@@ -214,14 +214,6 @@ varIfUnknown ty =

214replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d

215replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id

216

217−replaceTypeVars :: (D.Data d) => String -> Type -> d -> d

218−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)

219− where

220− replaceTypeVar (TypeVar v) | v == name = t

221− replaceTypeVar other = other

222− isShadowed (ForAll v _) | v == name = True

223− isShadowed _ = False

224−

225replaceAllVarsWithUnknowns :: Type -> Subst Type

217replaceAllVarsWithUnknowns :: Type -> Subst Type

226replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns

218replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns

227replaceAllVarsWithUnknowns ty = return ty

219replaceAllVarsWithUnknowns ty = return ty

src/Language/PureScript/Types.hs+10

@@ -17,6 +17,8 @@

17module Language.PureScript.Types where

19import Data.Data

20+import Data.Generics (mkT, mkQ, everywhereBut)

21+

20import Language.PureScript.Names

22import Language.PureScript.Names

21import Language.PureScript.Unknown (Unknown(..))

23import Language.PureScript.Unknown (Unknown(..))

@@ -65,3 +67,11 @@ mkForAll = flip . foldl . flip $ ForAll

66unit :: Type

68unit :: Type

67unit = Object REmpty

69unit = Object REmpty

70+

71+replaceTypeVars :: (Data d) => String -> Type -> d -> d

72+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)

73+ where

74+ replaceTypeVar (TypeVar v) | v == name = t

75+ replaceTypeVar other = other

76+ isShadowed (ForAll v _) | v == name = True

77+ isShadowed _ = False