git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Pass modified values up to codegen phase
e8621c9Phil Freeman
src/Language/PureScript.hs+5−4
compare with golang
unifiedsplit
@@ -27,15 +27,16 @@ import Language.PureScript.Sugar as P
27import Language.PureScript.Options as P
27import Language.PureScript.Options as P
28
28
29import Data.List (intercalate)
29import Data.List (intercalate)
30−import Control.Monad (when, forM_)
30+import Control.Monad (when, forM)
31+import Control.Applicative ((<$>))
31import qualified Data.Map as M
32import qualified Data.Map as M
32
33
33compile :: Options -> [Module] -> Either String (String, String, Environment)
34compile :: Options -> [Module] -> Either String (String, String, Environment)
34compile opts ms = do
35compile opts ms = do
35 desugared <- desugar ms
36 desugared <- desugar ms
36− (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
37+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls
37− let js = concatMap (flip (moduleToJs opts) env) $ desugared
38+ let js = concatMap (flip (moduleToJs opts) env) $ elaborated
38− let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
39+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elaborated
39 js' <- case () of
40 js' <- case () of
40 _ | optionsRunMain opts -> do
41 _ | optionsRunMain opts -> do
41 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $
42 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)
97valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
97valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
98valueToJs _ m e (Var ident) = varToJs m e ident
98valueToJs _ m e (Var ident) = varToJs m e ident
99valueToJs opts m e (TypedValue val _) = valueToJs opts m e val
99valueToJs opts m e (TypedValue val _) = valueToJs opts m e val
100+valueToJs _ _ _ (TypeClassDictionary _) = error "Type class dictionary was not replaced"
100valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
101valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
101
102
102runtimeTypeChecks :: [Ident] -> Type -> [JS]
103runtimeTypeChecks :: [Ident] -> Type -> [JS]
src/Language/PureScript/TypeChecker.hs+40−26
@@ -84,50 +84,59 @@ addValue moduleName name ty = do
84 env <- getEnv
84 env <- getEnv
85 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
85 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
86
86
87−typeCheckAll :: ModuleName -> [Declaration] -> Check ()
87+typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]
88−typeCheckAll _ [] = return ()
88+typeCheckAll _ [] = return []
89−typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
89+typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
90 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
90 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
91 typeIsNotDefined moduleName name
91 typeIsNotDefined moduleName name
92 ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
92 ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
93 addDataType moduleName name args dctors ctorKind
93 addDataType moduleName name args dctors ctorKind
94− typeCheckAll moduleName rest
94+ ds <- typeCheckAll moduleName rest
95+ return $ d : ds
95−typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do
96+typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
96 rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
97 rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
97 forM_ tys $ \(name, _, _) ->
98 forM_ tys $ \(name, _, _) ->
98 typeIsNotDefined moduleName name
99 typeIsNotDefined moduleName name
99 ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
100 ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
100 forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->
101 forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->
101 addDataType moduleName name args dctors ctorKind
102 addDataType moduleName name args dctors ctorKind
102− typeCheckAll moduleName rest
103+ ds <- typeCheckAll moduleName rest
104+ return $ d : ds
103−typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
105+typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
104 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
106 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
105 typeIsNotDefined moduleName name
107 typeIsNotDefined moduleName name
106 kind <- kindsOf moduleName name args [ty]
108 kind <- kindsOf moduleName name args [ty]
107 addTypeSynonym moduleName name args ty kind
109 addTypeSynonym moduleName name args ty kind
108− typeCheckAll moduleName rest
110+ ds <- typeCheckAll moduleName rest
111+ return $ d : ds
109typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
112typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
110typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do
113typeCheckAll 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
112 valueIsNotDefined moduleName name
115 valueIsNotDefined moduleName name
113− [ty] <- typesOf moduleName [(name, val)]
116+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]
114 addValue moduleName name ty
117 addValue moduleName name ty
118+ return $ ValueDeclaration name [] Nothing val'
115− typeCheckAll moduleName rest
119+ ds <- typeCheckAll moduleName rest
120+ return $ d : ds
116typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
121typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
117typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do
122typeCheckAll 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
119 forM_ (map fst vals) $ \name ->
124 forM_ (map fst vals) $ \name ->
120 valueIsNotDefined moduleName name
125 valueIsNotDefined moduleName name
121 tys <- typesOf moduleName vals
126 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
123 addValue moduleName name ty
128 addValue moduleName name ty
129+ return (name, val)
130+ return $ BindingGroupDeclaration vals'
124− typeCheckAll moduleName rest
131+ ds <- typeCheckAll moduleName rest
132+ return $ d : ds
125−typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do
133+typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do
126 env <- getEnv
134 env <- getEnv
127 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
135 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
128 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
136 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
129− typeCheckAll moduleName rest
137+ ds <- typeCheckAll moduleName rest
138+ return $ d : ds
130−typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
139+typeCheckAll moduleName (d@(ExternDeclaration name _ ty) : rest) = do
131 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
140 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
132 env <- getEnv
141 env <- getEnv
133 kind <- kindOf moduleName ty
142 kind <- kindOf moduleName ty
@@ -135,12 +144,14 @@ typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
135 case M.lookup (moduleName, name) (names env) of
144 case M.lookup (moduleName, name) (names env) of
136 Just _ -> throwError $ show name ++ " is already defined"
145 Just _ -> throwError $ show name ++ " is already defined"
137 Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern) (names env) })
146 Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern) (names env) })
138− typeCheckAll moduleName rest
147+ ds <- typeCheckAll moduleName rest
148+ return $ d : ds
139−typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
149+typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do
140− typeCheckAll moduleName rest
150+ ds <- typeCheckAll moduleName rest
141 env <- getEnv
151 env <- getEnv
142 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
152 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
153+ return $ d : ds
143−typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
154+typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
144 env <- getEnv
155 env <- getEnv
145 rethrow errorMessage $ do
156 rethrow errorMessage $ do
146 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
157 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
@@ -151,7 +162,8 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
151 Just idents' -> do
162 Just idents' -> do
152 shadowIdents (lefts idents') env
163 shadowIdents (lefts idents') env
153 shadowTypes (rights idents') env
164 shadowTypes (rights idents') env
154− typeCheckAll currentModule rest
165+ ds <- typeCheckAll currentModule rest
166+ return $ d : ds
155 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
167 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
156 filterModule = filter ((== moduleName) . fst) . M.keys
168 filterModule = filter ((== moduleName) . fst) . M.keys
157 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
169 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
@@ -185,10 +197,12 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
185 constructs (Function _ ty) pn = ty `constructs` pn
197 constructs (Function _ ty) pn = ty `constructs` pn
186 constructs (TypeApp ty _) pn = ty `constructs` pn
198 constructs (TypeApp ty _) pn = ty `constructs` pn
187 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
199 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
188−typeCheckAll moduleName (TypeClassDeclaration name arg decls : rest) = do
200+typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
189− typeCheckAll moduleName rest
201+ ds <- typeCheckAll moduleName rest
202+ return $ d : ds
190−typeCheckAll moduleName (TypeInstanceDeclaration deps name ty decls : rest) = do
203+typeCheckAll moduleName (d@(TypeInstanceDeclaration _ _ _ _) : rest) = do
191− typeCheckAll moduleName rest
204+ ds <- typeCheckAll moduleName rest
205+ return $ d : ds
192
206
193qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
207qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
194qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
208qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
src/Language/PureScript/TypeChecker/Kinds.hs+3−3
@@ -58,10 +58,10 @@ instance Unifiable Kind where
58 unknowns _ = []
58 unknowns _ = []
59
59
60kindOf :: ModuleName -> Type -> Check Kind
60kindOf :: 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
62
62
63kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
63kindsOf :: 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
65 tyCon <- fresh
65 tyCon <- fresh
66 kargs <- replicateM (length args) fresh
66 kargs <- replicateM (length args) fresh
67 let dict = (name, tyCon) : zip (map ProperName args) kargs
67 let dict = (name, tyCon) : zip (map ProperName args) kargs
@@ -69,7 +69,7 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _) -> k)) . runSub
69 solveTypes ts kargs tyCon
69 solveTypes ts kargs tyCon
70
70
71kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]
71kindsOfAll :: 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
73 tyCons <- replicateM (length tys) fresh
73 tyCons <- replicateM (length tys) fresh
74 let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
74 let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
75 bindLocalTypeVariables moduleName dict $
75 bindLocalTypeVariables moduleName dict $
src/Language/PureScript/TypeChecker/Monad.hs+2−2
@@ -159,10 +159,10 @@ liftCheck = Subst . lift . lift
159getSubstState :: Subst SubstState
159getSubstState :: Subst SubstState
160getSubstState = Subst . lift $ get
160getSubstState = Subst . lift $ get
161
161
162−runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution)
162+runSubst :: SubstContext -> Subst a -> Check (a, Substitution)
163runSubst context subst = do
163runSubst context subst = do
164 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
164 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
165− return (apply (substSubst s) a, substSubst s)
165+ return (a, substSubst s)
166
166
167substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
167substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
168substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
168substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
src/Language/PureScript/TypeChecker/Types.hs+16−12
@@ -140,9 +140,10 @@ unifyRows r1 r2 =
140typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
140typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
141typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
141typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
142
142
143−typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
143+typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
144typesOf moduleName vals = do
144typesOf moduleName vals = do
145+ tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)
145− (tys, _) <- runSubst (SubstContext moduleName) $ do
146+ . runSubst (SubstContext moduleName) $ do
146 let es = map isTyped vals
147 let es = map isTyped vals
147 typed = filter (isJust . snd . snd) es
148 typed = filter (isJust . snd . snd) es
148 untyped = filter (isNothing . snd . snd) es
149 untyped = filter (isNothing . snd . snd) es
@@ -150,31 +151,34 @@ typesOf moduleName vals = do
150 untypedNames <- replicateM (length untyped) fresh
151 untypedNames <- replicateM (length untyped) fresh
151 let untypedDict = zip (map fst untyped) untypedNames
152 let untypedDict = zip (map fst untyped) untypedNames
152 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
153 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
153− tys <- forM es $ \e -> do
154+ forM es $ \e -> do
154− (val, ty) <- case e of
155+ triple@(_, (val, ty)) <- case e of
155− (_, (val, Just ty)) -> do
156+ (ident, (val, Just ty)) -> do
156 kind <- liftCheck $ kindOf moduleName ty
157 kind <- liftCheck $ kindOf moduleName ty
157 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158 ty' <- replaceAllTypeSynonyms ty
159 ty' <- replaceAllTypeSynonyms ty
159 val' <- bindNames dict $ check val ty'
160 val' <- bindNames dict $ check val ty'
160− return (val', ty')
161+ return (ident, (val', ty'))
161 (ident, (val, Nothing)) -> do
162 (ident, (val, Nothing)) -> do
162 TypedValue val' ty <- bindNames dict $ infer val
163 TypedValue val' ty <- bindNames dict $ infer val
163 ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164 ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164− return (val', ty)
165+ return (ident, (val', ty))
165 when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
166 when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
166 [eff, a] <- replicateM 2 fresh
167 [eff, a] <- replicateM 2 fresh
167 ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
168 ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
168 escapeCheck val ty
169 escapeCheck val ty
169− return ty
170+ return triple
170− return tys
171− forM_ tys $ skolemEscapeCheck
171+ forM_ tys $ skolemEscapeCheck . snd . snd
172+ return $ map (\(ident, (val, ty)) -> ( ident, ( overTypes (desaturateAllTypeSynonyms . setifyAll) val
172− return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys
173+ , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))) tys
173
174
174isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))
175isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))
175isTyped (name, TypedValue value ty) = (name, (value, Just ty))
176isTyped (name, TypedValue value ty) = (name, (value, Just ty))
176isTyped (name, value) = (name, (value, Nothing))
177isTyped (name, value) = (name, (value, Nothing))
177
178
179+overTypes :: (Type -> Type) -> Value -> Value
180+overTypes f = everywhere (mkT f)
181+
178escapeCheck :: Value -> Type -> Subst ()
182escapeCheck :: Value -> Type -> Subst ()
179escapeCheck value ty = do
183escapeCheck value ty = do
180 subst <- substSubst <$> getSubstState
184 subst <- substSubst <$> getSubstState
@@ -594,7 +598,7 @@ check' val (ForAll idents ty) = do
594 check val sk
598 check val sk
595check' val (ConstrainedType constraints ty) = do
599check' val (ConstrainedType constraints ty) = do
596 val' <- check val ty
600 val' <- check val ty
597− return $ Abs [Ident "__dict"] val'
601+ return $ Abs (map (\_ -> Ident "__dict") constraints) val'
598check' val u@(TUnknown _) = do
602check' val u@(TUnknown _) = do
599 val'@(TypedValue _ ty) <- infer val
603 val'@(TypedValue _ ty) <- infer val
600 -- Don't unify an unknown with an inferred polytype
604 -- Don't unify an unknown with an inferred polytype