e8621c9 · rowtype-yoga/purescript-native

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

Pass modified values up to codegen phase

commite8621c9acda61fc1dd6c77bf9f49012acf59f3a5 authorPhil Freeman <paf31@cantab.net> dateTue 14 Jan 2014, 21:53 (13 years ago) parentff725e9

6 files changed+67−47

compare with golang

unifiedsplit

src/Language/PureScript.hs+5−4 src/Language/PureScript/CodeGen/JS.hs+1 src/Language/PureScript/TypeChecker.hs+40−26 src/Language/PureScript/TypeChecker/Kinds.hs+3−3 src/Language/PureScript/TypeChecker/Monad.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+16−12

src/Language/PureScript.hs+5−4

@@ -27,15 +27,16 @@ import Language.PureScript.Sugar as P

2727import Language.PureScript.Options as P

2828

2929import Data.List (intercalate)

30−import Control.Monad (when, forM_)

30+import Control.Monad (when, forM)

31+import Control.Applicative ((<$>))

3132import qualified Data.Map as M

3233

3334compile :: Options -> [Module] -> Either String (String, String, Environment)

3435compile opts ms = do

3536 desugared <- desugar ms

36− (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

37− let js = concatMap (flip (moduleToJs opts) env) $ desugared

38− let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

37+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

38+ let js = concatMap (flip (moduleToJs opts) env) $ elaborated

39+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elaborated

3940 js' <- case () of

4041 _ | optionsRunMain opts -> do

4142 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

src/Language/PureScript/CodeGen/JS.hs+1

@@ -97,6 +97,7 @@ valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

9797valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

9898valueToJs _ m e (Var ident) = varToJs m e ident

9999valueToJs opts m e (TypedValue val _) = valueToJs opts m e val

100+valueToJs _ _ _ (TypeClassDictionary _) = error "Type class dictionary was not replaced"

100101valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

101102

102103runtimeTypeChecks :: [Ident] -> Type -> [JS]

src/Language/PureScript/TypeChecker.hs+40−26

@@ -84,50 +84,59 @@ addValue moduleName name ty = do

8484 env <- getEnv

8585 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })

8686

87−typeCheckAll :: ModuleName -> [Declaration] -> Check ()

88−typeCheckAll _ [] = return ()

89−typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do

87+typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]

88+typeCheckAll _ [] = return []

89+typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do

9090 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

9191 typeIsNotDefined moduleName name

9292 ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)

9393 addDataType moduleName name args dctors ctorKind

94− typeCheckAll moduleName rest

95−typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do

94+ ds <- typeCheckAll moduleName rest

95+ return $ d : ds

96+typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

9697 rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do

9798 forM_ tys $ \(name, _, _) ->

9899 typeIsNotDefined moduleName name

99100 ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)

100101 forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->

101102 addDataType moduleName name args dctors ctorKind

102− typeCheckAll moduleName rest

103−typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do

103+ ds <- typeCheckAll moduleName rest

104+ return $ d : ds

105+typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

104106 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

105107 typeIsNotDefined moduleName name

106108 kind <- kindsOf moduleName name args [ty]

107109 addTypeSynonym moduleName name args ty kind

108− typeCheckAll moduleName rest

110+ ds <- typeCheckAll moduleName rest

111+ return $ d : ds

109112typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

110113typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

111− rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

114+ d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

112115 valueIsNotDefined moduleName name

113− [ty] <- typesOf moduleName [(name, val)]

116+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]

114117 addValue moduleName name ty

115− typeCheckAll moduleName rest

118+ return $ ValueDeclaration name [] Nothing val'

119+ ds <- typeCheckAll moduleName rest

120+ return $ d : ds

116121typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

117122typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

118− rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

123+ d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

119124 forM_ (map fst vals) $ \name ->

120125 valueIsNotDefined moduleName name

121126 tys <- typesOf moduleName vals

122− forM_ (zip (map fst vals) tys) $ \(name, ty) ->

127+ vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do

123128 addValue moduleName name ty

124− typeCheckAll moduleName rest

125−typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do

129+ return (name, val)

130+ return $ BindingGroupDeclaration vals'

131+ ds <- typeCheckAll moduleName rest

132+ return $ d : ds

133+typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do

126134 env <- getEnv

127135 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

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

129− typeCheckAll moduleName rest

130−typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do

137+ ds <- typeCheckAll moduleName rest

138+ return $ d : ds

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

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

132141 env <- getEnv

133142 kind <- kindOf moduleName ty

@@ -135,12 +144,14 @@ typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do

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

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

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

138− typeCheckAll moduleName rest

139−typeCheckAll moduleName (FixityDeclaration _ name : rest) = do

140− typeCheckAll moduleName rest

147+ ds <- typeCheckAll moduleName rest

148+ return $ d : ds

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

150+ ds <- typeCheckAll moduleName rest

141151 env <- getEnv

142152 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

143−typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

153+ return $ d : ds

154+typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

144155 env <- getEnv

145156 rethrow errorMessage $ do

146157 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

@@ -151,7 +162,8 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

151162 Just idents' -> do

152163 shadowIdents (lefts idents') env

153164 shadowTypes (rights idents') env

154− typeCheckAll currentModule rest

165+ ds <- typeCheckAll currentModule rest

166+ return $ d : ds

155167 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

156168 filterModule = filter ((== moduleName) . fst) . M.keys

157169 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

@@ -185,10 +197,12 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

185197 constructs (Function _ ty) pn = ty `constructs` pn

186198 constructs (TypeApp ty _) pn = ty `constructs` pn

187199 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

188−typeCheckAll moduleName (TypeClassDeclaration name arg decls : rest) = do

189− typeCheckAll moduleName rest

190−typeCheckAll moduleName (TypeInstanceDeclaration deps name ty decls : rest) = do

191− typeCheckAll moduleName rest

200+typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

201+ ds <- typeCheckAll moduleName rest

202+ return $ d : ds

203+typeCheckAll moduleName (d@(TypeInstanceDeclaration _ _ _ _) : rest) = do

204+ ds <- typeCheckAll moduleName rest

205+ return $ d : ds

192206

193207qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

194208qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

src/Language/PureScript/TypeChecker/Kinds.hs+3−3

@@ -58,10 +58,10 @@ instance Unifiable Kind where

5858 unknowns _ = []

5959

6060kindOf :: ModuleName -> Type -> Check Kind

61−kindOf moduleName ty = fmap (\(k, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty

61+kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty

6262

6363kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

64−kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _) -> k)) . runSubst (SubstContext moduleName) $ do

64+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do

6565 tyCon <- fresh

6666 kargs <- replicateM (length args) fresh

6767 let dict = (name, tyCon) : zip (map ProperName args) kargs

@@ -69,7 +69,7 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _) -> k)) . runSub

6969 solveTypes ts kargs tyCon

7070

7171kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]

72−kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, _) -> ks)) . runSubst (SubstContext moduleName) $ do

72+kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do

7373 tyCons <- replicateM (length tys) fresh

7474 let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

7575 bindLocalTypeVariables moduleName dict $

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

@@ -159,10 +159,10 @@ liftCheck = Subst . lift . lift

159159getSubstState :: Subst SubstState

160160getSubstState = Subst . lift $ get

161161

162−runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution)

162+runSubst :: SubstContext -> Subst a -> Check (a, Substitution)

163163runSubst context subst = do

164164 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst

165− return (apply (substSubst s) a, substSubst s)

165+ return (a, substSubst s)

166166

167167substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

168168substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do

src/Language/PureScript/TypeChecker/Types.hs+16−12

@@ -140,9 +140,10 @@ unifyRows r1 r2 =

140140typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

141141typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

142142

143−typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

143+typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

144144typesOf moduleName vals = do

145− (tys, _) <- runSubst (SubstContext moduleName) $ do

145+ tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)

146+ . runSubst (SubstContext moduleName) $ do

146147 let es = map isTyped vals

147148 typed = filter (isJust . snd . snd) es

148149 untyped = filter (isNothing . snd . snd) es

@@ -150,31 +151,34 @@ typesOf moduleName vals = do

150151 untypedNames <- replicateM (length untyped) fresh

151152 let untypedDict = zip (map fst untyped) untypedNames

152153 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

153− tys <- forM es $ \e -> do

154− (val, ty) <- case e of

155− (_, (val, Just ty)) -> do

154+ forM es $ \e -> do

155+ triple@(_, (val, ty)) <- case e of

156+ (ident, (val, Just ty)) -> do

156157 kind <- liftCheck $ kindOf moduleName ty

157158 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

158159 ty' <- replaceAllTypeSynonyms ty

159160 val' <- bindNames dict $ check val ty'

160− return (val', ty')

161+ return (ident, (val', ty'))

161162 (ident, (val, Nothing)) -> do

162163 TypedValue val' ty <- bindNames dict $ infer val

163164 ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

164− return (val', ty)

165+ return (ident, (val', ty))

165166 when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do

166167 [eff, a] <- replicateM 2 fresh

167168 ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a

168169 escapeCheck val ty

169− return ty

170− return tys

171− forM_ tys $ skolemEscapeCheck

172− return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys

170+ return triple

171+ forM_ tys $ skolemEscapeCheck . snd . snd

172+ return $ map (\(ident, (val, ty)) -> ( ident, ( overTypes (desaturateAllTypeSynonyms . setifyAll) val

173+ , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))) tys

173174

174175isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))

175176isTyped (name, TypedValue value ty) = (name, (value, Just ty))

176177isTyped (name, value) = (name, (value, Nothing))

177178

179+overTypes :: (Type -> Type) -> Value -> Value

180+overTypes f = everywhere (mkT f)

181+

178182escapeCheck :: Value -> Type -> Subst ()

179183escapeCheck value ty = do

180184 subst <- substSubst <$> getSubstState

@@ -594,7 +598,7 @@ check' val (ForAll idents ty) = do

594598 check val sk

595599check' val (ConstrainedType constraints ty) = do

596600 val' <- check val ty

597− return $ Abs [Ident "__dict"] val'

601+ return $ Abs (map (\_ -> Ident "__dict") constraints) val'

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

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

600604 -- Don't unify an unknown with an inferred polytype