git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix some aspects of code gen
commit418f44a61bf68de888f49d1536811c2f0d966615 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 17:38 (13 years ago) parent043ad39
8 files changed+59−45
compare with golang
unifiedsplit
examples/passing/TypeClasses.purs+6−5 src/Language/PureScript/CodeGen/JS.hs+5−2 src/Language/PureScript/Declarations.hs+6−1 src/Language/PureScript/Parser/Declarations.hs+3−3 src/Language/PureScript/Sugar/TypeClasses.hs+12−12 src/Language/PureScript/TypeChecker.hs+2−12 src/Language/PureScript/TypeChecker/Monad.hs+11−1 src/Language/PureScript/TypeChecker/Types.hs+14−9
examples/passing/TypeClasses.purs+6−5
@@ -22,17 +22,18 @@ test3 = show (Data "testing")
2222
2323class Monad m where
2424 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
2626
2727instance TypeClasses.Monad Data where
2828 ret = Data
29− bind (Data a) f = f a
29+ (>>=) (Data a) f = f a
3030
3131data Maybe a = Nothing | Just a
3232
3333instance TypeClasses.Monad Maybe where
3434 ret = Just
35− bind Nothing _ = Nothing
36− bind (Just a) f = f a
35+ (>>=) Nothing _ = Nothing
36+ (>>=) (Just a) f = f a
3737
38−test4 = Just 1 `bind` (\n -> Just (n + 1))
38+test4 :: forall m. (Monad m) => m Number
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 =
4545 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
4646 ]
4747 where
48− filterRawDecls (ExternDeclaration _ (Just js) _) = Just js
48+ filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js
4949 filterRawDecls _ = Nothing
5050
5151declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
@@ -68,6 +68,9 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
6868 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
6969 , ("value", JSVar (Ident "value")) ])])
7070 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 ]
7174declToJs _ _ _ _ = Nothing
7275
7376setProperty :: String -> JS -> ModuleName -> JS
@@ -135,7 +138,7 @@ varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e)
135138 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
136139 _ -> qualifiedToJS identToJs qual
137140 where
138− isExtern Extern = True
141+ isExtern (Extern ForeignImport) = True
139142 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
140143 Just (_, ty') -> isExtern ty'
141144 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
3232
3333data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
3434
35+data ForeignImportType
36+ = ForeignImport
37+ | TypeClassDictionaryImport
38+ | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
39+
3540data Declaration
3641 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
3742 | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]
@@ -39,7 +44,7 @@ data Declaration
3944 | TypeDeclaration Ident Type
4045 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
4146 | BindingGroupDeclaration [(Ident, Value)]
42− | ExternDeclaration Ident (Maybe JS) Type
47+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
4348 | ExternDataDeclaration ProperName Kind
4449 | FixityDeclaration Fixity String
4550 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
src/Language/PureScript/Parser/Declarations.hs+3−3
@@ -67,9 +67,9 @@ parseExternDeclaration :: P.Parsec String ParseState Declaration
6767parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
6868 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
6969 <*> (lexeme (indented *> P.string "::") *> parseKind)
70− <|> ExternDeclaration <$> parseIdent
71− <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)
72− <*> (lexeme (indented *> P.string "::") *> parsePolyType))
70+ <|> ExternDeclaration ForeignImport <$> parseIdent
71+ <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)
72+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))
7373
7474parseJSLiteral :: String -> JS
7575parseJSLiteral 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
3232import Data.Maybe (fromMaybe)
3333import Data.List (nub)
3434import Data.Generics (mkQ, everything)
35+import Language.PureScript.Pretty.Common (identToJs)
3536
3637type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
3738
@@ -52,11 +53,11 @@ desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
5253 desugared <- lift $ desugarCases members
5354 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
5455 dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared
55− return $ d : dictDecl : entries
56+ return $ d : entries ++ [dictDecl]
5657desugarDecl _ other = return [other]
5758
5859memberToNameAndType :: Declaration -> (String, Type)
59−memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)
60+memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
6061memberToNameAndType _ = error "Invalid declaration in type class definition"
6162
6263typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
@@ -65,16 +66,16 @@ typeClassDictionaryDeclaration name arg members =
6566
6667typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
6768typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
68− ExternDeclaration ident
69− (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor arg (JSVar (Ident "dict")))])))
70− (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
69+ ExternDeclaration TypeClassAccessorImport ident
70+ (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar (Ident "dict")))])))
71+ (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
7172typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
7273
7374typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
7475typeInstanceDictionaryDeclaration mn deps name ty decls = do
7576 entryName <- lift $ mkDictionaryValueName mn name ty
7677 memberNames <- mapM memberToNameAndValue decls
77− return $ ExternDeclaration entryName
78+ return $ ExternDeclaration TypeClassDictionaryImport entryName
7879 (Just (JSFunction (Just entryName)
7980 (map (\n -> Ident ('_' : show n)) [1..length deps])
8081 (JSBlock [JSReturn (JSObjectLiteral memberNames)])))
@@ -83,7 +84,8 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
8384 memberToNameAndValue :: Declaration -> Desugar (String, JS)
8485 memberToNameAndValue (ValueDeclaration ident _ _ _) = do
8586 memberName <- mkDictionaryEntryName mn name ty ident
86− return (identToString ident, JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
87+ return (identToJs ident, if null deps then JSVar memberName
88+ else JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
8789 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
8890
8991typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
@@ -91,16 +93,14 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [
9193 m <- get
9294 let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $
9395 do (arg, members) <- M.lookup (qualify mn name) m
94− ty' <- lookup (identToString ident) members
96+ ty' <- lookup (identToJs ident) members
9597 return $ replaceTypeVars arg ty ty'
9698 entryName <- mkDictionaryEntryName mn name ty ident
9799 return $ ValueDeclaration entryName [] Nothing
98100 (TypedValue val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
99101typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
100102
101−identToString :: Ident -> String
102−identToString (Ident s) = s
103−identToString (Op _) = error "TODO: Unsupported type class instance name"
103+--TODO handle unqualified names
104104
105105qualifiedToString :: ModuleName -> Qualified ProperName -> String
106106qualifiedToString 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"
130130mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
131131mkDictionaryEntryName mn name ty ident = do
132132 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
2424import Language.PureScript.TypeChecker.Types as T
2525import Language.PureScript.TypeChecker.Synonyms as T
2626
27−import Data.Data
28−import Data.Generics (mkT, everywhere)
2927import Data.Maybe
3028import qualified Data.Map as M
3129import Control.Monad.State
@@ -137,14 +135,14 @@ typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do
137135 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
138136 ds <- typeCheckAll moduleName rest
139137 return $ d : ds
140−typeCheckAll moduleName (d@(ExternDeclaration name _ ty) : rest) = do
138+typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
141139 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
142140 env <- getEnv
143141 kind <- kindOf moduleName ty
144142 guardWith "Expected kind *" $ kind == Star
145143 case M.lookup (moduleName, name) (names env) of
146144 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) })
148146 ds <- typeCheckAll moduleName rest
149147 return $ d : ds
150148typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do
@@ -206,11 +204,3 @@ typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest)
206204 ds <- withTypeClassDictionaries [(dictName, deps, className, ty)] $
207205 typeCheckAll moduleName rest
208206 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
2121import Language.PureScript.Kinds
2222import Language.PureScript.Names
2323import Language.PureScript.Unknown
24+import Language.PureScript.Declarations
2425
2526import Data.Data
2627import Data.Maybe
2728import Data.Monoid
29+import Data.Generics (mkT, everywhere)
30+
2831import Control.Applicative
2932import Control.Monad.State
3033import Control.Monad.Error
@@ -34,7 +37,7 @@ import qualified Data.Map as M
3437
3538data NameKind
3639 = Value
37− | Extern
40+ | Extern ForeignImportType
3841 | Alias ModuleName Ident
3942 | LocalVariable
4043 | DataConstructor deriving Show
@@ -233,3 +236,10 @@ fresh' = do
233236
234237fresh :: (Unifiable t) => Subst t
235238fresh = 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)
189189 go other = return other
190190
191191entails :: 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
193193 env <- getEnv
194194 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
196196 (dict : _) -> return dict
197197 where
198− go env (className, ty) =
198+ go env (className', ty') =
199199 [ App (Var (Qualified Nothing fnName)) args
200− | (fnName, subgoals, className', ty') <- context
201− , className == className'
202− , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty ty'
200+ | (fnName, subgoals, className'', ty'') <- context
201+ , className' == className''
202+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' ty''
203203 , args <- forM (replaceAllTypeVars subst subgoals) (go env) ]
204204
205205typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
@@ -354,8 +354,9 @@ infer' (Var var) = do
354354 ty' <- replaceAllTypeSynonyms ty
355355 case ty' of
356356 ConstrainedType constraints _ -> do
357+ env <- getEnv
357358 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'
359360 _ -> return $ TypedValue (Var var) ty'
360361infer' (Block ss) = do
361362 ret <- fresh
@@ -633,10 +634,12 @@ check' val (ForAll idents ty) = do
633634 sk <- skolemize idents ty
634635 check val sk
635636check' val (ConstrainedType constraints ty) = do
637+ env <- getEnv
638+ moduleName <- substCurrentModule <$> ask
636639 dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
637640 n <- liftCheck freshDictionaryName
638641 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
640643 return $ Abs dictNames val'
641644check' val u@(TUnknown _) = do
642645 val'@(TypedValue _ ty) <- infer val
@@ -776,8 +779,10 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do
776779 ty <- expandTypeSynonym name tyArgs
777780 checkFunctionApplication fn ty args ret
778781checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do
782+ env <- getEnv
779783 dicts <- getTypeClassDictionaries
780− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy args ret
784+ moduleName <- substCurrentModule <$> ask
785+ checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret
781786checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "
782787 ++ prettyPrintType fnTy
783788 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)