f0eb3e1 · rowtype-yoga/purescript-native

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

Fix kind checking, code gen for dictionaries

commitf0eb3e183e7ac7f092e979542952319d762c4b9c authorPhil Freeman <paf31@cantab.net> dateSun 12 Jan 2014, 21:21 (13 years ago) parent199d052

6 files changed+33−18

compare with golang

unifiedsplit

examples/passing/TypeClasses.purs+2 src/Language/PureScript/Pretty/Types.hs+1 src/Language/PureScript/Sugar/TypeClasses.hs+14−9 src/Language/PureScript/TypeChecker/Kinds.hs+5 src/Language/PureScript/TypeChecker/Types.hs+1−9 src/Language/PureScript/Types.hs+10

examples/passing/TypeClasses.purs+2

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

66instance TypeClasses.Show String where

77 show s = s

9+test = show "testing"

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

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

3737 match (TypeConstructor ctor) = Just $ show ctor

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

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

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

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

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

4243 match REmpty = Just $ prettyPrintRow REmpty

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

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

2828import Control.Monad.State

2929import Data.Maybe (fromMaybe)

3030

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

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

3232

3333desugarTypeClasses :: [Module] -> [Module]

3434desugarTypeClasses = flip evalState M.empty . mapM desugarModule

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

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

4040desugarDecl mn (TypeClassDeclaration name arg members) = do

4141 let tys = map memberToNameAndType members

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

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

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

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

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

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

5757typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

5858typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

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

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

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

6363

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

6565typeInstanceDictionaryDeclaration deps name ty decls =

6666 ExternDeclaration (mkDictionaryValueName name ty)

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

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

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

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

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

6971 where

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

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

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

7478

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

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

7781 m <- get

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

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

80− lookup (identToString ident) members

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

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

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

85+ return $ replaceTypeVars arg ty ty'

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

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

8489

8590identToString :: Ident -> String

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

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

136136 k2 <- infer row

137137 k2 ~~ Row k1

138138 return $ Row k1

139+infer (ConstrainedType deps ty) = do

140+ mapM_ (infer . snd) deps

141+ k <- infer ty

142+ k ~~ Star

143+ return Star

139144infer _ = error "Invalid argument to infer"

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

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

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

2424import qualified Data.Data as D

2525import Data.Generics

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

26+ (mkT, something, everywhere, mkQ)

2727

2828import Language.PureScript.Values

2929import Language.PureScript.Types

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

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

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

216216

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−

225217replaceAllVarsWithUnknowns :: Type -> Subst Type

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

227219replaceAllVarsWithUnknowns ty = return ty

src/Language/PureScript/Types.hs+10

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

1717module Language.PureScript.Types where

1818

1919import Data.Data

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

21+

2022import Language.PureScript.Names

2123import Language.PureScript.Unknown (Unknown(..))

2224

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

6567

6668unit :: Type

6769unit = 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