save work

purefunctor · purefunctor · commit 4d68ebd4002b · 2023-05-02T01:19:10.000+08:00
diff --git a/src/Language/PureScript/Interface/Types.hs b/src/Language/PureScript/Interface/Types.hs
@@ -15,8 +15,13 @@ import Language.PureScript.Sugar.Names.Env (primEnv)
 import Language.PureScript.TypeChecker (typeCheckModule, emptyCheckState, debugType)
 import Text.Pretty.Simple (pPrint)
 import Data.String (String)
+import Language.PureScript.AST.Binders (Binder (..))
+import Debug.Pretty.Simple (pTraceShow)
 
-data NodeContext = DeclarationNode | ExpressionNode
+data NodeContext 
+  = DeclarationNode
+  | BinderNode
+  | ExpressionNode
   deriving (Show)
 
 data NodeInfo a = NodeInfo
@@ -69,8 +74,8 @@ mergeASTs xs@(x : xr) ys@(y : yr)
 source :: Text
 source = unlines
   [ "module Main where"
-  , "values :: Array Int"
-  , "values = [0, 1]"
+  , "values :: Int -> Array Int"
+  , "values x = [x]"
   ]
 
 main :: IO ()
@@ -90,21 +95,32 @@ main = do
 
   where
   declarationToAST :: Declaration -> [InterfaceAST String]
-  (declarationToAST, _, _, _, _) = everythingOnValues mergeASTs onDecl onExpr noAST noAST noAST 
+  (declarationToAST, _, _, _, _) = everythingOnValues mergeASTs onDecl onExpr onBinder noAST noAST 
     where
     noAST :: forall a. a -> [InterfaceAST String]
     noAST = const []
 
     onDecl :: Declaration -> [InterfaceAST String]
     onDecl = \case
-      ValueDecl (s, _) _ _ _ [MkUnguarded (TypedValue _ (PositionedValue _ _ _) t)] ->
-        [ makeNode (NodeInfo (debugType t) DeclarationNode) s ]
-      _ ->
-        []
+      -- ValueDecl (s, _) _ _ _ [MkUnguarded (TypedValue _ (PositionedValue _ _ _) t)] ->
+      --   [ makeNode (NodeInfo (debugType t) DeclarationNode) s ]
+      e ->
+        pTraceShow e []
 
     onExpr :: Expr -> [InterfaceAST String]
     onExpr = \case
       TypedValue _ (PositionedValue s _ _) t ->
         [ makeNode (NodeInfo (debugType t) ExpressionNode) s ]
       _ ->
         []
+
+    onBinder :: Binder -> [InterfaceAST String]
+    onBinder = \case
+      TypedBinder t (LiteralBinder s _) ->
+        [ makeNode (NodeInfo (debugType t) BinderNode) s ]
+      TypedBinder t (VarBinder s _) ->
+        [ makeNode (NodeInfo (debugType t) BinderNode) s ]
+      TypedBinder t (ConstructorBinder s _ _) ->
+        [ makeNode (NodeInfo (debugType t) BinderNode) s ]
+      _ -> 
+        []
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -683,8 +683,9 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
   guardWith (errorMessage $ OverlappingArgNames Nothing) $
     let ns = concatMap binderNames binders in length (ordNub ns) == length ns
   m1 <- M.unions <$> zipWithM inferBinder nvals binders
+  let binders' = zipWith TypedBinder nvals binders
   r <- bindLocalVariables [ (ss, name, ty, Defined) | (name, (ss, ty)) <- M.toList m1 ] $
-       CaseAlternative binders <$> forM result (\ge -> checkGuardedRhs ge ret)
+       CaseAlternative binders' <$> forM result (\ge -> checkGuardedRhs ge ret)
   rs <- checkBinders nvals ret bs
   return $ r : rs
 
@@ -707,7 +708,7 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do
                                                  | (name, (ss, bty)) <- M.toList variables
                                                  ] $
     checkGuardedRhs (GuardedExpr guards rhs) ret
-  return $ GuardedExpr (PatternGuard binder (tvToExpr tv) : guards') rhs'
+  return $ GuardedExpr (PatternGuard (TypedBinder ty binder) (tvToExpr tv) : guards') rhs'
 
 -- |
 -- Check the type of a value, rethrowing errors to provide a better error message
@@ -779,7 +780,7 @@ check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy)
   | VarBinder ss arg <- binder = do
       unifyTypes t tyFunction
       ret' <- withBindingGroupVisible $ bindLocalVariables [(ss, arg, argTy, Defined)] $ check ret retTy
-      return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty
+      return $ TypedValue' True (Abs (TypedBinder argTy (VarBinder ss arg)) (tvToExpr ret')) ty
   | otherwise = internalError "Binder was not desugared"
 check' (App f arg) ret = do
   f'@(TypedValue' _ _ ft) <- infer f
