git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
More work on mutually recursive values, still not working.
24872f8Phil Freeman
src/Language/PureScript/BindingGroups.hs+23−14
compare with golang
unifiedsplit
@@ -21,6 +21,7 @@ import Data.List (intersect)
21
21
22import Language.PureScript.Declarations
22import Language.PureScript.Declarations
23import Language.PureScript.Names
23import Language.PureScript.Names
24+import Language.PureScript.Values
24import Language.PureScript.Scope (usedNames)
25import Language.PureScript.Scope (usedNames)
25
26
26createBindingGroups :: [Declaration] -> [Declaration]
27createBindingGroups :: [Declaration] -> [Declaration]
@@ -33,17 +34,25 @@ createBindingGroups ds =
33 sorted = map toBindingGroup $ stronglyConnComp verts
34 sorted = map toBindingGroup $ stronglyConnComp verts
34 in
35 in
35 map handleModuleDeclaration nonValues ++ sorted
36 map handleModuleDeclaration nonValues ++ sorted
36− where
37+
37− isValueDecl :: Declaration -> Bool
38+isValueDecl :: Declaration -> Bool
38− isValueDecl (ValueDeclaration _ _ _ _) = True
39+isValueDecl (ValueDeclaration _ _ _ _) = True
39− isValueDecl _ = False
40+isValueDecl _ = False
41+
40− getIdent :: Declaration -> Ident
42+getIdent :: Declaration -> Ident
41− getIdent (ValueDeclaration ident _ _ _) = ident
43+getIdent (ValueDeclaration ident _ _ _) = ident
42− getIdent _ = error "undefined"
44+getIdent _ = error "Expected ValueDeclaration"
45+
43− toBindingGroup :: SCC Declaration -> Declaration
46+toBindingGroup :: SCC Declaration -> Declaration
44− toBindingGroup (AcyclicSCC d) = d
47+toBindingGroup (AcyclicSCC d) = d
45− toBindingGroup (CyclicSCC [d]) = d
48+toBindingGroup (CyclicSCC [d]) = d
46− toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration ds'
49+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration (map fromValueDecl ds')
50+
51+fromValueDecl :: Declaration -> (Ident, Value)
52+fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
53+fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
54+fromValueDecl _ = error "Expected ValueDeclaration"
55+
47− handleModuleDeclaration :: Declaration -> Declaration
56+handleModuleDeclaration :: Declaration -> Declaration
48− handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
57+handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
49− handleModuleDeclaration other = other
58+handleModuleDeclaration other = other
src/Language/PureScript/CodeGen/JS.hs+11
@@ -31,6 +31,7 @@ import Language.PureScript.Pretty.Common
31import Language.PureScript.CodeGen.Monad
31import Language.PureScript.CodeGen.Monad
32import Language.PureScript.CodeGen.JS.AST as AST
32import Language.PureScript.CodeGen.JS.AST as AST
33import Language.PureScript.TypeChecker.Monad (NameKind(..))
33import Language.PureScript.TypeChecker.Monad (NameKind(..))
34+import Debug.Trace (trace)
34
35
35declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
36declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
36declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
37declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
@@ -39,6 +40,16 @@ declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
39declToJs curMod mp (ValueDeclaration ident _ _ val) e =
40declToJs curMod mp (ValueDeclaration ident _ _ val) e =
40 Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
41 Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
41 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
42 maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
43+declToJs curMod mp (BindingGroupDeclaration vals) e = trace (show [ JSApp (JSFunction Nothing [] (JSBlock (concatMap (\(ident, val) ->
44+ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
45+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
46+ ) vals))) []
47+ ]) $
48+ Just [ JSApp (JSFunction Nothing [] (JSBlock (concatMap (\(ident, val) ->
49+ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
50+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
51+ ) vals))) []
52+ ]
42declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
53declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
43 Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
54 Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
44 maybe [] (return . setProperty (show ident) (JSVar ident)) curMod
55 maybe [] (return . setProperty (show ident) (JSVar ident)) curMod
src/Language/PureScript/Declarations.hs+1−1
@@ -34,7 +34,7 @@ data Declaration
34 | TypeSynonymDeclaration ProperName [String] PolyType
34 | TypeSynonymDeclaration ProperName [String] PolyType
35 | TypeDeclaration Ident PolyType
35 | TypeDeclaration Ident PolyType
36 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
36 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
37− | BindingGroupDeclaration [Declaration]
37+ | BindingGroupDeclaration [(Ident, Value)]
38 | ExternDeclaration Ident PolyType
38 | ExternDeclaration Ident PolyType
39 | ExternMemberDeclaration String Ident PolyType
39 | ExternMemberDeclaration String Ident PolyType
40 | ExternDataDeclaration ProperName Kind
40 | ExternDataDeclaration ProperName Kind
src/Language/PureScript/TypeChecker.hs+13−2
@@ -70,11 +70,22 @@ typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do
70 case M.lookup (modulePath, name) (names env) of
70 case M.lookup (modulePath, name) (names env) of
71 Just _ -> throwError $ show name ++ " is already defined"
71 Just _ -> throwError $ show name ++ " is already defined"
72 Nothing -> do
72 Nothing -> do
73− ty <- typeOf (Just name) val
73+ [ty] <- typesOf [(name, val)]
74 putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
74 putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
75 typeCheckAll rest
75 typeCheckAll rest
76typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
76typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
77−typeCheckAll (BindingGroupDeclaration ds : rest) = error $ show ds
77+typeCheckAll (BindingGroupDeclaration vals : rest) = do
78+ rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
79+ modulePath <- checkModulePath `fmap` get
80+ forM_ (map fst vals) $ \name -> do
81+ env <- getEnv
82+ case M.lookup (modulePath, name) (names env) of
83+ Just _ -> throwError $ show name ++ " is already defined"
84+ Nothing -> return ()
85+ tys <- typesOf vals
86+ forM (zip (map fst vals) tys) $ \(name, ty) ->
87+ modifyEnv $ \env -> env { names = M.insert (modulePath, name) (ty, Value) (names env) }
88+ typeCheckAll rest
78typeCheckAll (ExternDataDeclaration name kind : rest) = do
89typeCheckAll (ExternDataDeclaration name kind : rest) = do
79 env <- getEnv
90 env <- getEnv
80 modulePath <- checkModulePath `fmap` get
91 modulePath <- checkModulePath `fmap` get
src/Language/PureScript/TypeChecker/Monad.hs+7
@@ -163,6 +163,13 @@ class (Typeable t, Data t, Show t) => Unifiable t where
163 apply :: Substitution -> t -> t
163 apply :: Substitution -> t -> t
164 unknowns :: t -> [Int]
164 unknowns :: t -> [Int]
165
165
166+instance (Unifiable a) => Unifiable [a] where
167+ unknown _ = error "not supported"
168+ (~~) = zipWithM_ (~~)
169+ isUnknown _ = error "not supported"
170+ apply s = map (apply s)
171+ unknowns = concatMap unknowns
172+
166occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
173occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
167occursCheck (Unknown u) t =
174occursCheck (Unknown u) t =
168 case isUnknown t of
175 case isUnknown t of
src/Language/PureScript/TypeChecker/Types.hs+32−28
@@ -15,11 +15,12 @@
15{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
15{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
16
16
17module Language.PureScript.TypeChecker.Types (
17module Language.PureScript.TypeChecker.Types (
18− typeOf
18+ typesOf
19) where
19) where
20
20
21import Data.List
21import Data.List
22import Data.Maybe (fromMaybe)
22import Data.Maybe (fromMaybe)
23+import Data.Either (lefts, rights)
23import qualified Data.Data as D
24import qualified Data.Data as D
24import Data.Generics
25import Data.Generics
25 (mkT, something, everywhere, everywhereBut, mkQ, extQ)
26 (mkT, something, everywhere, everywhereBut, mkQ, extQ)
@@ -139,33 +140,36 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
139 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
140 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
140 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
141 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
141
142
142−isFunction :: Value -> Bool
143−isFunction (Abs _ _) = True
144−isFunction (TypedValue untyped _) = isFunction untyped
145−isFunction _ = False
146−
147−typeOf :: Maybe Ident -> Value -> Check Type
143+typesOf :: [(Ident, Value)] -> Check [Type]
148−typeOf name val = do
144+typesOf vals = do
149− (ty, sub, checks) <- runSubst $ case name of
145+ (tys, sub, checks) <- runSubst $ do
150− Just ident | isFunction val ->
146+ modulePath <- checkModulePath <$> get
147+ let es = map isTyped vals
148+ typed = lefts es
149+ untyped = rights es
150+ typedDict = map (\(ident, ty, _) -> (ident, ty)) typed
151+ untypedNames <- replicateM (length untyped) fresh
152+ let untypedDict = zip (map fst untyped) untypedNames
153+ dict = M.fromList (map (\(ident, ty) -> ((modulePath, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
151− case val of
154+ tys <- forM es $ \e -> case e of
152− TypedValue value ty -> do
155+ Left (_, ty, val) -> do
153− kind <- liftCheck $ kindOf ty
156+ kind <- liftCheck $ kindOf ty
154− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
157+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
155− ty' <- replaceAllTypeSynonyms ty
158+ ty' <- replaceAllTypeSynonyms ty
156− modulePath <- checkModulePath <$> get
159+ bindNames dict $ check val ty'
157− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
158− return ty'
160+ return ty'
159− _ -> do
161+ Right (ident, val) -> do
160− me <- fresh
161− modulePath <- checkModulePath <$> get
162− ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
162+ ty <- bindNames dict $ infer val
163− ty ~~ me
163+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164− return ty
164+ return ty
165− _ -> infer val
165+ return tys
166− escapeCheck checks ty sub
166+ forM tys $ flip (escapeCheck checks) sub
167− skolemEscapeCheck ty
167+ forM tys $ skolemEscapeCheck
168− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
168+ return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys
169+
170+isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)
171+isTyped (name, TypedValue value ty) = Left (name, ty, value)
172+isTyped (name, value) = Right (name, value)
169
173
170escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
174escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
171escapeCheck checks ty sub =
175escapeCheck checks ty sub =