git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
More work on mutually recursive values, still not working.
commit24872f8e565af3a62f2cda55fed1f5d4e8fd5317 authorPhil Freeman <paf31@cantab.net> dateSun 29 Dec 2013, 15:30 (13 years ago) parent37a94cd
6 files changed+87−45
compare with golang
unifiedsplit
src/Language/PureScript/BindingGroups.hs+23−14 src/Language/PureScript/CodeGen/JS.hs+11 src/Language/PureScript/Declarations.hs+1−1 src/Language/PureScript/TypeChecker.hs+13−2 src/Language/PureScript/TypeChecker/Monad.hs+7 src/Language/PureScript/TypeChecker/Types.hs+32−28
src/Language/PureScript/BindingGroups.hs+23−14
@@ -21,6 +21,7 @@ import Data.List (intersect)
2121
2222import Language.PureScript.Declarations
2323import Language.PureScript.Names
24+import Language.PureScript.Values
2425import Language.PureScript.Scope (usedNames)
2526
2627createBindingGroups :: [Declaration] -> [Declaration]
@@ -33,17 +34,25 @@ createBindingGroups ds =
3334 sorted = map toBindingGroup $ stronglyConnComp verts
3435 in
3536 map handleModuleDeclaration nonValues ++ sorted
36− where
37− isValueDecl :: Declaration -> Bool
38− isValueDecl (ValueDeclaration _ _ _ _) = True
39− isValueDecl _ = False
40− getIdent :: Declaration -> Ident
41− getIdent (ValueDeclaration ident _ _ _) = ident
42− getIdent _ = error "undefined"
43− toBindingGroup :: SCC Declaration -> Declaration
44− toBindingGroup (AcyclicSCC d) = d
45− toBindingGroup (CyclicSCC [d]) = d
46− toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration ds'
47− handleModuleDeclaration :: Declaration -> Declaration
48− handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
49− handleModuleDeclaration other = other
37+
38+isValueDecl :: Declaration -> Bool
39+isValueDecl (ValueDeclaration _ _ _ _) = True
40+isValueDecl _ = False
41+
42+getIdent :: Declaration -> Ident
43+getIdent (ValueDeclaration ident _ _ _) = ident
44+getIdent _ = error "Expected ValueDeclaration"
45+
46+toBindingGroup :: SCC Declaration -> Declaration
47+toBindingGroup (AcyclicSCC d) = d
48+toBindingGroup (CyclicSCC [d]) = d
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+
56+handleModuleDeclaration :: Declaration -> Declaration
57+handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
58+handleModuleDeclaration other = other
src/Language/PureScript/CodeGen/JS.hs+11
@@ -31,6 +31,7 @@ import Language.PureScript.Pretty.Common
3131import Language.PureScript.CodeGen.Monad
3232import Language.PureScript.CodeGen.JS.AST as AST
3333import Language.PureScript.TypeChecker.Monad (NameKind(..))
34+import Debug.Trace (trace)
3435
3536declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
3637declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
@@ -39,6 +40,16 @@ declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
3940declToJs curMod mp (ValueDeclaration ident _ _ val) e =
4041 Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
4142 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+ ]
4253declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
4354 Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
4455 maybe [] (return . setProperty (show ident) (JSVar ident)) curMod
src/Language/PureScript/Declarations.hs+1−1
@@ -34,7 +34,7 @@ data Declaration
3434 | TypeSynonymDeclaration ProperName [String] PolyType
3535 | TypeDeclaration Ident PolyType
3636 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
37− | BindingGroupDeclaration [Declaration]
37+ | BindingGroupDeclaration [(Ident, Value)]
3838 | ExternDeclaration Ident PolyType
3939 | ExternMemberDeclaration String Ident PolyType
4040 | ExternDataDeclaration ProperName Kind
src/Language/PureScript/TypeChecker.hs+13−2
@@ -70,11 +70,22 @@ typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do
7070 case M.lookup (modulePath, name) (names env) of
7171 Just _ -> throwError $ show name ++ " is already defined"
7272 Nothing -> do
73− ty <- typeOf (Just name) val
73+ [ty] <- typesOf [(name, val)]
7474 putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
7575 typeCheckAll rest
7676typeCheckAll (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
7889typeCheckAll (ExternDataDeclaration name kind : rest) = do
7990 env <- getEnv
8091 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
163163 apply :: Substitution -> t -> t
164164 unknowns :: t -> [Int]
165165
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+
166173occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
167174occursCheck (Unknown u) t =
168175 case isUnknown t of
src/Language/PureScript/TypeChecker/Types.hs+32−28
@@ -15,11 +15,12 @@
1515{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
1616
1717module Language.PureScript.TypeChecker.Types (
18− typeOf
18+ typesOf
1919) where
2020
2121import Data.List
2222import Data.Maybe (fromMaybe)
23+import Data.Either (lefts, rights)
2324import qualified Data.Data as D
2425import Data.Generics
2526 (mkT, something, everywhere, everywhereBut, mkQ, extQ)
@@ -139,33 +140,36 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
139140 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
140141 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
141142
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
148−typeOf name val = do
149− (ty, sub, checks) <- runSubst $ case name of
150− Just ident | isFunction val ->
151− case val of
152− TypedValue value ty -> do
153− kind <- liftCheck $ kindOf ty
154− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
155− ty' <- replaceAllTypeSynonyms ty
156− modulePath <- checkModulePath <$> get
157− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
158− return ty'
159− _ -> do
160− me <- fresh
161− modulePath <- checkModulePath <$> get
162− ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
163− ty ~~ me
164− return ty
165− _ -> infer val
166− escapeCheck checks ty sub
167− skolemEscapeCheck ty
168− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
143+typesOf :: [(Ident, Value)] -> Check [Type]
144+typesOf vals = do
145+ (tys, sub, checks) <- runSubst $ do
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)
154+ tys <- forM es $ \e -> case e of
155+ Left (_, ty, val) -> do
156+ kind <- liftCheck $ kindOf ty
157+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158+ ty' <- replaceAllTypeSynonyms ty
159+ bindNames dict $ check val ty'
160+ return ty'
161+ Right (ident, val) -> do
162+ ty <- bindNames dict $ infer val
163+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164+ return ty
165+ return tys
166+ forM tys $ flip (escapeCheck checks) sub
167+ forM tys $ skolemEscapeCheck
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)
169173
170174escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
171175escapeCheck checks ty sub =