abd9791 · rowtype-yoga/purescript-native

examples/passing/TypeClasses.purs+11−1

compare with golang

unifiedsplit

@@ -1,5 +1,8 @@

1module TypeClasses where

2

3+import Eff

4+import Trace

5+

3class Show a where

6class Show a where

4 show :: a -> String

7 show :: a -> String

5

8

@@ -36,4 +39,11 @@ instance TypeClasses.Monad Maybe where

36 (>>=) (Just a) f = f a

39 (>>=) (Just a) f = f a

37

40

38test4 :: forall m. (Monad m) => m Number

41test4 :: forall m. (Monad m) => m Number

39−test4 = ret 1--Just 1 >>= \n -> Just (n + 1)

42+test4 = ret 1

43+

44+test5 = Just 1 >>= \n -> ret (n + 1)

45+

46+module Main where

47+

48+main = eff do

49+ print TypeClasses.test5

src/Language/PureScript/CodeGen/JS.hs+9−2

@@ -19,10 +19,13 @@ module Language.PureScript.CodeGen.JS (

19) where

20

21import Data.Maybe (mapMaybe)

22−import qualified Data.Map as M

22+import Data.List (sortBy)

23+

23import Control.Arrow (second)

24import Control.Arrow (second)

24import Control.Monad (replicateM, forM)

25import Control.Monad (replicateM, forM)

25

26

27+import qualified Data.Map as M

28+

26import Language.PureScript.TypeChecker (Environment(..), NameKind(..))

29import Language.PureScript.TypeChecker (Environment(..), NameKind(..))

27import Language.PureScript.Values

30import Language.PureScript.Values

28import Language.PureScript.Names

31import Language.PureScript.Names

@@ -40,13 +43,17 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =

40 mapMaybe filterRawDecls decls ++

43 mapMaybe filterRawDecls decls ++

41 [ JSVariableIntroduction (Ident name) Nothing

44 [ JSVariableIntroduction (Ident name) Nothing

42 , JSApp (JSFunction Nothing [Ident name]

45 , JSApp (JSFunction Nothing [Ident name]

43− (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) decls)))

46+ (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))

44 [JSAssignment (JSAssignVariable (Ident name))

47 [JSAssignment (JSAssignVariable (Ident name))

45 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

48 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

46 ]

49 ]

47 where

50 where

48 filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js

51 filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js

49 filterRawDecls _ = Nothing

52 filterRawDecls _ = Nothing

53+ typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ

54+ typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT

55+ typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT

56+ typeClassesLast _ _ = EQ

50

57

51declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

58declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

52declToJs opts mp (ValueDeclaration ident _ _ val) e =

59declToJs opts mp (ValueDeclaration ident _ _ val) e =

src/Language/PureScript/Sugar/TypeClasses.hs−2

@@ -100,8 +100,6 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [

100 (TypedValue val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

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

102

103−--TODO handle unqualified names

104−

105qualifiedToString :: ModuleName -> Qualified ProperName -> String

103qualifiedToString :: ModuleName -> Qualified ProperName -> String

106qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

104qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

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

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

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

@@ -32,6 +32,7 @@ import Data.Either (rights, lefts)

32

33import Language.PureScript.Types

34import Language.PureScript.Names

35+import Language.PureScript.Values

35import Language.PureScript.Kinds

36import Language.PureScript.Kinds

36import Language.PureScript.Declarations

37import Language.PureScript.Declarations

37import Language.PureScript.Sugar.TypeClasses

38import Language.PureScript.Sugar.TypeClasses

@@ -201,6 +202,6 @@ typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

201 return $ d : ds

202 return $ d : ds

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

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

203 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

204 dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

204− ds <- withTypeClassDictionaries [(dictName, deps, className, ty)] $

205+ ds <- withTypeClassDictionaries [TypeClassDictionaryInScope dictName className ty (Just deps)] $

205 typeCheckAll moduleName rest

206 typeCheckAll moduleName rest

206 return $ d : ds

207 return $ d : ds

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

@@ -19,6 +19,7 @@ module Language.PureScript.TypeChecker.Monad where

19

20import Language.PureScript.Types

21import Language.PureScript.Kinds

22+import Language.PureScript.Values

22import Language.PureScript.Names

23import Language.PureScript.Names

23import Language.PureScript.Unknown

24import Language.PureScript.Unknown

24import Language.PureScript.Declarations

25import Language.PureScript.Declarations

@@ -54,7 +55,7 @@ data Environment = Environment

54 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

55 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

55 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

56 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

56 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

57 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

57− , typeClassDictionaries :: [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)]

58+ , typeClassDictionaries :: [TypeClassDictionaryInScope]

58 } deriving (Show)

59 } deriving (Show)

59

60

60emptyEnvironment :: Environment

61emptyEnvironment :: Environment

@@ -76,7 +77,7 @@ bindTypes newNames action = do

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

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

77 return a

78 return a

78

79

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

80+withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

80withTypeClassDictionaries entries action = do

81withTypeClassDictionaries entries action = do

81 orig <- get

82 orig <- get

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

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

@@ -84,7 +85,7 @@ withTypeClassDictionaries entries action = do

84 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

85 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

85 return a

86 return a

86

87

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

88+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]

88getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

89getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

89

90

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

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

src/Language/PureScript/TypeChecker/Types.hs+13−7

@@ -188,7 +188,7 @@ replaceTypeClassDictionaries mn = everywhereM (mkM go)

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

189 go other = return other

190

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

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

192entails moduleName context goal@(className, ty) = do

193 env <- getEnv

194 case go env goal of

@@ -196,11 +196,17 @@ entails moduleName context goal@(className, ty) = do

196 (dict : _) -> return dict

197 where

198 go env (className', ty') =

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

199+ [ mkDictionary (tcdName tcd) args

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

200+ | tcd <- context

201− , qualify moduleName className' == qualify moduleName className''

201+ , qualify moduleName className' == qualify moduleName (tcdClassName tcd)

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

202+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)

203+ , args <- solveSubgoals env subst (tcdDependencies tcd) ]

204+ solveSubgoals _ _ Nothing = [Nothing]

205+ solveSubgoals env subst (Just subgoals) = do

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

206+ dict <- mapM (go env) (replaceAllTypeVars subst subgoals)

207+ return $ Just dict

208+ mkDictionary fnName Nothing = Var (Qualified Nothing fnName)

209+ mkDictionary fnName (Just args) = App (Var (Qualified Nothing fnName)) args

204

210

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

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

206typeHeadsAreEqual _ _ String String = Just []

212typeHeadsAreEqual _ _ String String = Just []

@@ -639,7 +645,7 @@ check' val (ConstrainedType constraints ty) = do

639 dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do

645 dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do

640 n <- liftCheck freshDictionaryName

646 n <- liftCheck freshDictionaryName

641 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

647 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

642− val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> (name, [], className, instanceTy)) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty

648+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty

643 return $ Abs dictNames val'

649 return $ Abs dictNames val'

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

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

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

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

src/Language/PureScript/Values.hs+8−1

@@ -73,7 +73,14 @@ 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)], Qualified ProperName, Type)] deriving (Show, Data, Typeable)

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

77+

78+data TypeClassDictionaryInScope

79+ = TypeClassDictionaryInScope { tcdName :: Ident

80+ , tcdClassName :: Qualified ProperName

81+ , tcdInstanceType :: Type

82+ , tcdDependencies :: Maybe [(Qualified ProperName, Type)]

83+ } deriving (Show, Data, Typeable)

77

84

78data DoNotationElement

85data DoNotationElement

79 = DoNotationValue Value

86 = DoNotationValue Value