abd9791 · rowtype-yoga/purescript-native

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

CodeGen fixes

commitabd9791cb31b619dcbe913f2cf52a3ffae5641dd authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 19:31 (13 years ago) parentbf0e439

7 files changed+47−17

compare with golang

unifiedsplit

examples/passing/TypeClasses.purs+11−1 src/Language/PureScript/CodeGen/JS.hs+9−2 src/Language/PureScript/Sugar/TypeClasses.hs−2 src/Language/PureScript/TypeChecker.hs+2−1 src/Language/PureScript/TypeChecker/Monad.hs+4−3 src/Language/PureScript/TypeChecker/Types.hs+13−7 src/Language/PureScript/Values.hs+8−1

examples/passing/TypeClasses.purs+11−1

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

11module TypeClasses where

3+import Eff

4+import Trace

36class Show a where

47 show :: a -> String

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

3639 (>>=) (Just a) f = f a

3740

3841test4 :: 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 (

1919) where

2020

2121import Data.Maybe (mapMaybe)

22−import qualified Data.Map as M

22+import Data.List (sortBy)

23+

2324import Control.Arrow (second)

2425import Control.Monad (replicateM, forM)

2526

27+import qualified Data.Map as M

28+

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

2730import Language.PureScript.Values

2831import Language.PureScript.Names

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

4043 mapMaybe filterRawDecls decls ++

4144 [ JSVariableIntroduction (Ident name) Nothing

4245 , 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))))

4447 [JSAssignment (JSAssignVariable (Ident name))

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

4649 ]

4750 where

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

4952 filterRawDecls _ = Nothing

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

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

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

56+ typeClassesLast _ _ = EQ

5057

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

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

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

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

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

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

102102

103−--TODO handle unqualified names

104−

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

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

107105qualifiedToString _ (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)

3232

3333import Language.PureScript.Types

3434import Language.PureScript.Names

35+import Language.PureScript.Values

3536import Language.PureScript.Kinds

3637import Language.PureScript.Declarations

3738import Language.PureScript.Sugar.TypeClasses

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

201202 return $ d : ds

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

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

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

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

205206 typeCheckAll moduleName rest

206207 return $ d : ds

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

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

1919

2020import Language.PureScript.Types

2121import Language.PureScript.Kinds

22+import Language.PureScript.Values

2223import Language.PureScript.Names

2324import Language.PureScript.Unknown

2425import Language.PureScript.Declarations

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

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

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

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

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

58+ , typeClassDictionaries :: [TypeClassDictionaryInScope]

5859 } deriving (Show)

5960

6061emptyEnvironment :: Environment

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

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

7778 return a

7879

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

8081withTypeClassDictionaries entries action = do

8182 orig <- get

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

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

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

8586 return a

8687

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

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

8889getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

8990

9091bindLocalVariables :: (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)

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

189189 go other = return other

190190

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

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

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

193193 env <- getEnv

194194 case go env goal of

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

196196 (dict : _) -> return dict

197197 where

198198 go env (className', ty') =

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

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

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

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

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

199+ [ mkDictionary (tcdName tcd) args

200+ | tcd <- context

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

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

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

204210

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

206212typeHeadsAreEqual _ _ String String = Just []

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

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

640646 n <- liftCheck freshDictionaryName

641647 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

643649 return $ Abs dictNames val'

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

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

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

@@ -73,7 +73,14 @@ data Value

7373 | Case [Value] [([Binder], Maybe Guard, Value)]

7474 | TypedValue Value Type

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

7784

7885data DoNotationElement

7986 = DoNotationValue Value