First work on fixing the skolems bug purescript#147

paf31 · garyb · commit 97d123eb6c7a · 2014-02-06T16:24:46.000Z
diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs
@@ -0,0 +1,9 @@
+module SkolemEscape where
+
+import Prelude
+import Eff
+import ST
+
+test _ = do
+  r <- runST (newSTRef 0)
+  ret 0 
diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs
@@ -10,10 +10,10 @@ test1 = catchError (\s -> ret 0) $ do
           trace "Testing"
           throwError "Error!"
 
-test2 = runPure $ runST $ do
+test2 = runST (do
           ref <- newSTRef 0
           modifySTRef ref $ \n -> n + 1
-          readSTRef ref
+          readSTRef ref)
 
 module Main where
 
@@ -24,4 +24,4 @@ import TestEff
 main = do
   n <- test1
   Trace.print n
-  Trace.print test2
+  --Trace.print test2
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
@@ -128,7 +128,7 @@ runtimeTypeChecks arg ty =
   where
   getFunctionArgumentType :: Type -> Maybe Type
   getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
-  getFunctionArgumentType (ForAll _ ty') = getFunctionArgumentType ty'
+  getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
   getFunctionArgumentType _ = Nothing
   argumentCheck :: JS -> Type -> [JS]
   argumentCheck val t | t == tyNumber = [typeCheck val "number"]
@@ -141,7 +141,7 @@ runtimeTypeChecks arg ty =
     in
       typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
   argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
-  argumentCheck val (ForAll _ ty') = argumentCheck val ty'
+  argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
   argumentCheck _ _ = []
   typeCheck :: JS -> String -> JS
   typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
@@ -253,7 +253,7 @@ isOnlyConstructor m e ctor =
   where
   numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
   typeConstructor (TypeConstructor qual) = qualify m qual
-  typeConstructor (ForAll _ ty) = typeConstructor ty
+  typeConstructor (ForAll _ ty _) = typeConstructor ty
   typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
   typeConstructor (TypeApp ty _) = typeConstructor ty
   typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -36,10 +36,10 @@ typeLiterals = mkPattern match
   match (TypeApp arr ty) | arr == tyArray = Just $ "[" ++ prettyPrintType ty ++ "]"
   match (TypeConstructor ctor) = Just $ show ctor
   match (TUnknown (Unknown u)) = Just $ 'u' : show u
-  match (Skolem s) = Just $ 's' : show s
+  match (Skolem s _) = Just $ 's' : show s
   match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty
   match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
-  match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
+  match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
   match REmpty = Just $ prettyPrintRow REmpty
   match row@(RCons _ _ _) = Just $ prettyPrintRow row
   match _ = Nothing
@@ -56,7 +56,7 @@ prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs
   tailToPs REmpty = ""
   tailToPs (TUnknown (Unknown u)) = " | u" ++ show u
   tailToPs (TypeVar var) = " | " ++ var
-  tailToPs (Skolem s) = " | s" ++ show s
+  tailToPs (Skolem s _) = " | s" ++ show s
   tailToPs _ = error "Invalid row tail"
   toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
   toList tys (RCons name ty row) = toList ((name, ty):tys) row
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -74,7 +74,7 @@ typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> De
 typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
   ExternDeclaration TypeClassAccessorImport ident
     (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
-    (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
+    (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing)
 typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
 
 typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
@@ -120,7 +120,7 @@ qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (J
 qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn
 
 quantify :: Type -> Type
-quantify ty' = foldr ForAll ty' tyVars
+quantify ty' = foldr (\arg t -> ForAll arg t Nothing) ty' tyVars
   where
   tyVars = nub $ everything (++) (mkQ [] collect) ty'
   collect (TypeVar v) = [v]
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -230,7 +230,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
       addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
   constructs (TypeConstructor (Qualified (Just mn) pn')) pn
     = mn == moduleName && pn' == pn
-  constructs (ForAll _ ty) pn = ty `constructs` pn
+  constructs (ForAll _ ty _) pn = ty `constructs` pn
   constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn
   constructs (TypeApp ty _) pn = ty `constructs` pn
   constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -142,7 +142,7 @@ infer (TypeApp t1 t2) = do
   k2 <- infer t2
   k1 =?= FunKind k2 k0
   return k0
-infer (ForAll ident ty) = do
+infer (ForAll ident ty _) = do
   k <- fresh
   Just moduleName <- checkCurrentModule <$> get
   bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
