Skip to content

Commit 24872f8

Browse files
paf31paf31
committed
More work on mutually recursive values, still not working.
1 parent 37a94cd commit 24872f8

File tree

6 files changed

+87
-45
lines changed

6 files changed

+87
-45
lines changed

‎src/Language/PureScript/BindingGroups.hs‎

Lines changed: 23 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ import Data.List (intersect)
2121

2222
import Language.PureScript.Declarations
2323
import Language.PureScript.Names
24+
import Language.PureScript.Values
2425
import Language.PureScript.Scope (usedNames)
2526

2627
createBindingGroups :: [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‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Language.PureScript.Pretty.Common
3131
import Language.PureScript.CodeGen.Monad
3232
import Language.PureScript.CodeGen.JS.AST as AST
3333
import Language.PureScript.TypeChecker.Monad (NameKind(..))
34+
import Debug.Trace (trace)
3435

3536
declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
3637
declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
@@ -39,6 +40,16 @@ declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
3940
declToJs 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+
]
4253
declToJs 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‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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
7676
typeCheckAll (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
7889
typeCheckAll (ExternDataDeclaration name kind : rest) = do
7990
env <- getEnv
8091
modulePath <- checkModulePath `fmap` get

‎src/Language/PureScript/TypeChecker/Monad.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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+
166173
occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
167174
occursCheck (Unknown u) t =
168175
case isUnknown t of

‎src/Language/PureScript/TypeChecker/Types.hs‎

Lines changed: 32 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -15,11 +15,12 @@
1515
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
1616

1717
module Language.PureScript.TypeChecker.Types (
18-
typeOf
18+
typesOf
1919
) where
2020

2121
import Data.List
2222
import Data.Maybe (fromMaybe)
23+
import Data.Either (lefts, rights)
2324
import qualified Data.Data as D
2425
import 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

170174
escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
171175
escapeCheck checks ty sub =

0 commit comments

Comments
 (0)