git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #376 and make types more easily understandable by pushing foralls before constraints in type class members.
807426aPhil Freeman
examples/passing/Sequence.pursnew file+12
compare with golang
unifiedsplit
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Control.Monad.Eff
4+
5+class Sequence t where
6+ sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
7+
8+instance sequenceArray :: Sequence [] where
9+ sequence [] = pure []
10+ sequence (x:xs) = (:) <$> x <*> sequence xs
11+
12+main = sequence $ [Debug.Trace.trace "Done"]
src/Language/PureScript/Sugar/TypeClasses.hs+5−5
@@ -145,7 +145,7 @@ typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> D
145typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
145typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
146 ExternDeclaration TypeClassAccessorImport ident
146 ExternDeclaration TypeClassAccessorImport ident
147 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
147 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
148− (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
148+ (moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty)))
149typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
149typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
150 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
150 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
151typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
151typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
@@ -169,7 +169,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
169 case mapMaybe declName tyDecls \\ mapMaybe declName decls of
169 case mapMaybe declName tyDecls \\ mapMaybe declName decls of
170 x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
170 x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
171 [] -> do
171 [] -> do
172−
172+
173 let instanceTys = map memberToNameAndType tyDecls
173 let instanceTys = map memberToNameAndType tyDecls
174
174
175 -- Replace the type arguments with the appropriate types in the member types
175 -- Replace the type arguments with the appropriate types in the member types
@@ -192,16 +192,16 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
192 dictTy = foldl TypeApp (TypeConstructor className) tys
192 dictTy = foldl TypeApp (TypeConstructor className) tys
193 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
193 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
194 dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
194 dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
195−
195+
196 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
196 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
197−
197+
198 where
198 where
199
199
200 declName :: Declaration -> Maybe Ident
200 declName :: Declaration -> Maybe Ident
201 declName (PositionedDeclaration _ d) = declName d
201 declName (PositionedDeclaration _ d) = declName d
202 declName (ValueDeclaration ident _ _ _ _) = Just ident
202 declName (ValueDeclaration ident _ _ _ _) = Just ident
203 declName (TypeDeclaration ident _) = Just ident
203 declName (TypeDeclaration ident _) = Just ident
204− declName _ = Nothing
204+ declName _ = Nothing
205
205
206 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
206 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
207 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
207 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
src/Language/PureScript/Types.hs+19
@@ -182,3 +182,22 @@ freeTypeVariables = nub . go []
182--
182--
183quantify :: Type -> Type
183quantify :: Type -> Type
184quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
184quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
185+
186+-- |
187+-- Move all universal quantifiers to the front of a type
188+--
189+moveQuantifiersToFront :: Type -> Type
190+moveQuantifiersToFront = go [] []
191+ where
192+ go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty
193+ go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
194+ go qs cs ty =
195+ let constrained = case cs of
196+ [] -> ty
197+ cs' -> ConstrainedType cs' ty
198+ in case qs of
199+ [] -> constrained
200+ qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
201+
202+
203+