418f44a · rowtype-yoga/purescript-native

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

on golang help sign in

Fix some aspects of code gen

418f44aPhil Freeman13 years ago

examples/passing/TypeClasses.purs+6−5

compare with golang

unifiedsplit

@@ -22,17 +22,18 @@ test3 = show (Data "testing")

23class Monad m where

24 ret :: forall a. a -> m a

25− bind :: forall a b. m a -> (a -> m b) -> m b

25+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

27instance TypeClasses.Monad Data where

28 ret = Data

29− bind (Data a) f = f a

29+ (>>=) (Data a) f = f a

31data Maybe a = Nothing | Just a

33instance TypeClasses.Monad Maybe where

34 ret = Just

35− bind Nothing _ = Nothing

35+ (>>=) Nothing _ = Nothing

36− bind (Just a) f = f a

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

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

38−test4 = Just 1 `bind` (\n -> Just (n + 1))

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

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

@@ -45,7 +45,7 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =

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

46 ]

47 where

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

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

49 filterRawDecls _ = Nothing

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

@@ -68,6 +68,9 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

68 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

69 , ("value", JSVar (Ident "value")) ])])

70 in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

71+declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ | importTy /= ForeignImport =

72+ Just [ js

73+ , setProperty (identToJs ident) (JSVar ident) mp ]

71declToJs _ _ _ _ = Nothing

74declToJs _ _ _ _ = Nothing

73setProperty :: String -> JS -> ModuleName -> JS

76setProperty :: String -> JS -> ModuleName -> JS

@@ -135,7 +138,7 @@ varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e)

135 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

138 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

136 _ -> qualifiedToJS identToJs qual

139 _ -> qualifiedToJS identToJs qual

137 where

140 where

138− isExtern Extern = True

141+ isExtern (Extern ForeignImport) = True

139 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

142 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

140 Just (_, ty') -> isExtern ty'

143 Just (_, ty') -> isExtern ty'

141 Nothing -> error "Undefined alias in varToJs"

144 Nothing -> error "Undefined alias in varToJs"

src/Language/PureScript/Declarations.hs+6−1

@@ -32,6 +32,11 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable

33data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

35+data ForeignImportType

36+ = ForeignImport

37+ | TypeClassDictionaryImport

38+ | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

39+

35data Declaration

40data Declaration

36 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

41 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

37 | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]

42 | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]

@@ -39,7 +44,7 @@ data Declaration

39 | TypeDeclaration Ident Type

44 | TypeDeclaration Ident Type

40 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

45 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

41 | BindingGroupDeclaration [(Ident, Value)]

46 | BindingGroupDeclaration [(Ident, Value)]

42− | ExternDeclaration Ident (Maybe JS) Type

47+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

43 | ExternDataDeclaration ProperName Kind

48 | ExternDataDeclaration ProperName Kind

44 | FixityDeclaration Fixity String

49 | FixityDeclaration Fixity String

45 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

50 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

src/Language/PureScript/Parser/Declarations.hs+3−3

@@ -67,9 +67,9 @@ parseExternDeclaration :: P.Parsec String ParseState Declaration

67parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

68 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

69 <*> (lexeme (indented *> P.string "::") *> parseKind)

70− <|> ExternDeclaration <$> parseIdent

70+ <|> ExternDeclaration ForeignImport <$> parseIdent

71− <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)

71+ <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)

72− <*> (lexeme (indented *> P.string "::") *> parsePolyType))

72+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))

74parseJSLiteral :: String -> JS

75parseJSLiteral s = either (const $ JSRaw s) id $ P.runParser parseJS () "Javascript" s

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

@@ -32,6 +32,7 @@ import Control.Monad.State

32import Data.Maybe (fromMaybe)

33import Data.List (nub)

34import Data.Generics (mkQ, everything)

35+import Language.PureScript.Pretty.Common (identToJs)

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

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

@@ -52,11 +53,11 @@ desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

52 desugared <- lift $ desugarCases members

53 desugared <- lift $ desugarCases members

53 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

54 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

54 dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared

55 dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared

55− return $ d : dictDecl : entries

56+ return $ d : entries ++ [dictDecl]

56desugarDecl _ other = return [other]

57desugarDecl _ other = return [other]

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

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

59−memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)

60+memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

60memberToNameAndType _ = error "Invalid declaration in type class definition"

61memberToNameAndType _ = error "Invalid declaration in type class definition"

62typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration

63typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration

@@ -65,16 +66,16 @@ typeClassDictionaryDeclaration name arg members =

66typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

67typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

67typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

68typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

68− ExternDeclaration ident

69+ ExternDeclaration TypeClassAccessorImport ident

69− (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor arg (JSVar (Ident "dict")))])))

70+ (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar (Ident "dict")))])))

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

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

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

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

73typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

74typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

74typeInstanceDictionaryDeclaration mn deps name ty decls = do

75typeInstanceDictionaryDeclaration mn deps name ty decls = do

75 entryName <- lift $ mkDictionaryValueName mn name ty

76 entryName <- lift $ mkDictionaryValueName mn name ty

76 memberNames <- mapM memberToNameAndValue decls

77 memberNames <- mapM memberToNameAndValue decls

77− return $ ExternDeclaration entryName

78+ return $ ExternDeclaration TypeClassDictionaryImport entryName

78 (Just (JSFunction (Just entryName)

79 (Just (JSFunction (Just entryName)

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

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

80 (JSBlock [JSReturn (JSObjectLiteral memberNames)])))

81 (JSBlock [JSReturn (JSObjectLiteral memberNames)])))

@@ -83,7 +84,8 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do

83 memberToNameAndValue :: Declaration -> Desugar (String, JS)

84 memberToNameAndValue :: Declaration -> Desugar (String, JS)

84 memberToNameAndValue (ValueDeclaration ident _ _ _) = do

85 memberToNameAndValue (ValueDeclaration ident _ _ _) = do

85 memberName <- mkDictionaryEntryName mn name ty ident

86 memberName <- mkDictionaryEntryName mn name ty ident

87+ return (identToJs ident, if null deps then JSVar memberName

86− return (identToString ident, JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))

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

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

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

89typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

91typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

@@ -91,16 +93,14 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [

91 m <- get

93 m <- get

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

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

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

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

94− ty' <- lookup (identToString ident) members

96+ ty' <- lookup (identToJs ident) members

95 return $ replaceTypeVars arg ty ty'

97 return $ replaceTypeVars arg ty ty'

96 entryName <- mkDictionaryEntryName mn name ty ident

98 entryName <- mkDictionaryEntryName mn name ty ident

97 return $ ValueDeclaration entryName [] Nothing

99 return $ ValueDeclaration entryName [] Nothing

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

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

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

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

100

102

101−identToString :: Ident -> String

103+--TODO handle unqualified names

102−identToString (Ident s) = s

103−identToString (Op _) = error "TODO: Unsupported type class instance name"

104

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

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

@@ -130,4 +130,4 @@ typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"

130mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident

131mkDictionaryEntryName mn name ty ident = do

132 Ident dictName <- lift $ mkDictionaryValueName mn name ty

133− return $ Ident $ dictName ++ "_" ++ identToString ident

133+ return $ Ident $ dictName ++ "_" ++ identToJs ident

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

@@ -24,8 +24,6 @@ import Language.PureScript.TypeChecker.Kinds as T

24import Language.PureScript.TypeChecker.Types as T

25import Language.PureScript.TypeChecker.Synonyms as T

27−import Data.Data

28−import Data.Generics (mkT, everywhere)

29import Data.Maybe

27import Data.Maybe

30import qualified Data.Map as M

28import qualified Data.Map as M

31import Control.Monad.State

29import Control.Monad.State

@@ -137,14 +135,14 @@ typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do

137 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

135 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

138 ds <- typeCheckAll moduleName rest

136 ds <- typeCheckAll moduleName rest

139 return $ d : ds

137 return $ d : ds

140−typeCheckAll moduleName (d@(ExternDeclaration name _ ty) : rest) = do

138+typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

141 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

139 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

142 env <- getEnv

140 env <- getEnv

143 kind <- kindOf moduleName ty

141 kind <- kindOf moduleName ty

144 guardWith "Expected kind *" $ kind == Star

142 guardWith "Expected kind *" $ kind == Star

145 case M.lookup (moduleName, name) (names env) of

143 case M.lookup (moduleName, name) (names env) of

146 Just _ -> throwError $ show name ++ " is already defined"

144 Just _ -> throwError $ show name ++ " is already defined"

147− Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern) (names env) })

145+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })

148 ds <- typeCheckAll moduleName rest

146 ds <- typeCheckAll moduleName rest

149 return $ d : ds

147 return $ d : ds

150typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do

148typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do

@@ -206,11 +204,3 @@ typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest)

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

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

207 typeCheckAll moduleName rest

205 typeCheckAll moduleName rest

208 return $ d : ds

206 return $ d : ds

209−

210−qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

211−qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

212− where

213− go :: Qualified ProperName -> Qualified ProperName

214− go qual = let (mn', pn') = canonicalizeType mn env qual

215− in Qualified (Just mn') pn'

216−

src/Language/PureScript/TypeChecker/Monad.hs+11−1

@@ -21,10 +21,13 @@ import Language.PureScript.Types

21import Language.PureScript.Kinds

22import Language.PureScript.Names

23import Language.PureScript.Unknown

24+import Language.PureScript.Declarations

25import Data.Data

26import Data.Data

26import Data.Maybe

27import Data.Maybe

27import Data.Monoid

28import Data.Monoid

29+import Data.Generics (mkT, everywhere)

30+

28import Control.Applicative

31import Control.Applicative

29import Control.Monad.State

32import Control.Monad.State

30import Control.Monad.Error

33import Control.Monad.Error

@@ -34,7 +37,7 @@ import qualified Data.Map as M

35data NameKind

38data NameKind

36 = Value

39 = Value

37− | Extern

40+ | Extern ForeignImportType

38 | Alias ModuleName Ident

41 | Alias ModuleName Ident

39 | LocalVariable

42 | LocalVariable

40 | DataConstructor deriving Show

43 | DataConstructor deriving Show

@@ -233,3 +236,10 @@ fresh' = do

233

236

234fresh :: (Unifiable t) => Subst t

237fresh :: (Unifiable t) => Subst t

235fresh = unknown . Unknown <$> fresh'

238fresh = unknown . Unknown <$> fresh'

239+

240+qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

241+qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

242+ where

243+ go :: Qualified ProperName -> Qualified ProperName

244+ go qual = let (mn', pn') = canonicalizeType mn env qual

245+ in Qualified (Just mn') pn'

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

@@ -189,17 +189,17 @@ replaceTypeClassDictionaries mn = everywhereM (mkM go)

189 go other = return other

190

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

192−entails moduleName context goal = do

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

193 env <- getEnv

194 case go env goal of

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

195+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty

196 (dict : _) -> return dict

197 where

198− go env (className, ty) =

198+ go env (className', ty') =

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

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

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

201− , className == className'

201+ , className' == className''

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

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

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

204

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

@@ -354,8 +354,9 @@ infer' (Var var) = do

354 ty' <- replaceAllTypeSynonyms ty

355 case ty' of

356 ConstrainedType constraints _ -> do

357+ env <- getEnv

357 dicts <- getTypeClassDictionaries

358 dicts <- getTypeClassDictionaries

358− return $ TypedValue (App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

359+ return $ TypedValue (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

359 _ -> return $ TypedValue (Var var) ty'

360 _ -> return $ TypedValue (Var var) ty'

360infer' (Block ss) = do

361infer' (Block ss) = do

361 ret <- fresh

362 ret <- fresh

@@ -633,10 +634,12 @@ check' val (ForAll idents ty) = do

633 sk <- skolemize idents ty

634 sk <- skolemize idents ty

634 check val sk

635 check val sk

635check' val (ConstrainedType constraints ty) = do

636check' val (ConstrainedType constraints ty) = do

637+ env <- getEnv

638+ moduleName <- substCurrentModule <$> ask

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

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

637 n <- liftCheck freshDictionaryName

640 n <- liftCheck freshDictionaryName

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

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

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

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

640 return $ Abs dictNames val'

643 return $ Abs dictNames val'

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

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

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

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

@@ -776,8 +779,10 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

776 ty <- expandTypeSynonym name tyArgs

779 ty <- expandTypeSynonym name tyArgs

777 checkFunctionApplication fn ty args ret

780 checkFunctionApplication fn ty args ret

778checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

781checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

782+ env <- getEnv

779 dicts <- getTypeClassDictionaries

783 dicts <- getTypeClassDictionaries

784+ moduleName <- substCurrentModule <$> ask

780− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy args ret

785+ checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret

781checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

786checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

782 ++ prettyPrintType fnTy

787 ++ prettyPrintType fnTy

783 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

788 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)