Fix types in pattersgit add .git add .

src/LambdaLifter.hs

@@ -86,8 +86,8 @@ freeVarsBranch localVars (Branch (patt, t) exp) = (frees, AnnBranch (patt, t) ex
     freeVarsOfPattern = Set.fromList . go []
       where
         go acc = \case
-            PVar (n,_) -> snoc n acc
+            PVar n    -> snoc n acc
-            PInj _ ps  ->  foldl go acc ps
+            PInj _ ps ->  foldl go acc $ map fst ps
 
 
 

src/Monomorphizer/Monomorphizer.hs

@@ -32,9 +32,8 @@ import           TypeChecker.TypeCheckerIr     (Ident (Ident))
 
 import           Control.Monad.Reader          (MonadReader (ask, local),
                                                 Reader, asks, runReader, when)
-import           Control.Monad.State           (MonadState,
+import           Control.Monad.State           (MonadState, StateT (runStateT),
-                                                StateT (runStateT), gets,
+                                                gets, modify)
-                                                modify)
 import           Data.Coerce                   (coerce)
 import qualified Data.Map                      as Map
 import           Data.Maybe                    (fromJust)
@@ -220,17 +219,17 @@ morphBranch (T.Branch (p, pt) (e, et)) = do
   pt' <- getMonoFromPoly pt
   et' <- getMonoFromPoly et
   env <- ask
-  (p', newLocals)  <- morphPattern pt' (locals env) p
+  (p', newLocals)  <- morphPattern pt' (locals env) (p, pt)
   local (const env { locals = newLocals }) $ do
     e' <- morphExp et' e
     return $ M.Branch (p', pt') (e', et')
 
 -- | Morphs pattern (pattern => expression), gives the newly bound local variables.
-morphPattern :: M.Type -> Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident)
+morphPattern :: M.Type -> Set.Set Ident -> (T.Pattern, T.Type) -> EnvM (M.Pattern, Set.Set Ident)
-morphPattern expectedType ls = \case
+morphPattern expectedType ls (p, t) = case p of
-  T.PVar (ident, t) -> do t' <- getMonoFromPoly t
+  T.PVar ident -> do t' <- getMonoFromPoly t
                      return (M.PVar (ident, t'), Set.insert ident ls)
-  T.PLit (lit, t) ->   do t' <- getMonoFromPoly t
+  T.PLit lit ->   do t' <- getMonoFromPoly t
                      return (M.PLit (convertLit lit, t'), ls)
   T.PCatch -> return (M.PCatch, ls)
   -- Constructor ident

src/TypeChecker/RemoveForall.hs

@@ -30,13 +30,14 @@ removeForall (Program defs) = Program $ map (DData . rfData) ds
         ELit lit    -> ELit lit
         EVar name   -> EVar name
         EInj name   -> EInj name
-    rfBranch (Branch (p, t) e) = Branch (rfPattern p, rfType t) (rfExpT e)
+    rfBranch (Branch p e) = Branch (rfPatternT p) (rfExpT e)
+    rfPatternT (p, t) = (rfPattern p, rfType t)
     rfPattern = \case
-        PVar id       -> PVar (rfId id)
+        PVar name    -> PVar name
-        PLit (lit, t) -> PLit (lit, rfType t)
+        PLit lit     -> PLit lit
         PCatch       -> PCatch
         PEnum name   -> PEnum name
-        PInj name ps  -> PInj name (map rfPattern ps)
+        PInj name ps -> PInj name (map rfPatternT ps)
 
 rfType :: R.Type -> Type
 rfType = \case

src/TypeChecker/ReportTEVar.hs

@@ -49,10 +49,13 @@ instance ReportTEVar (Exp' G.Type) (Exp' Type) where
 instance ReportTEVar (Branch' G.Type) (Branch' Type) where
     reportTEVar (Branch (patt, t_patt) e) = liftA2 Branch (liftA2 (,) (reportTEVar patt) (reportTEVar t_patt)) (reportTEVar e)
 
+instance ReportTEVar (Pattern' G.Type, G.Type) (Pattern' Type, Type) where
+    reportTEVar (p, t) = liftA2 (,) (reportTEVar p) (reportTEVar t)
+
 instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where
     reportTEVar = \case
-        PVar (name, t) -> PVar . (name,) <$> reportTEVar t
+        PVar name    -> pure $ PVar name
-        PLit (lit, t)  -> PLit . (lit,) <$> reportTEVar t
+        PLit lit     -> pure $ PLit lit
         PCatch       -> pure PCatch
         PEnum name   -> pure $ PEnum name
         PInj name ps -> PInj name <$> reportTEVar ps

src/TypeChecker/TypeCheckerBidir.hs

@@ -209,7 +209,7 @@ checkPattern patt t_patt = case patt of
         --  Γ ⊢ x ↑ A ⊣ Γ,(x:A)
         PVar x -> do
             insertEnv $ EnvVar x t_patt
-            apply (T.PVar (coerce x, t_patt), t_patt)
+            apply (T.PVar (coerce x), t_patt)
 
         --  -------------
         --  Γ ⊢ _ ↑ A ⊣ Γ
@@ -220,7 +220,7 @@ checkPattern patt t_patt = case patt of
         --  Γ ⊢ τ ↑ B ⊣ Δ
         PLit lit -> do
           subtype (litType lit) t_patt
-          apply (T.PLit (lit, t_patt), t_patt)
+          apply (T.PLit lit, t_patt)
 
         --  Γ ∋ (K : A)  Γ ⊢ A <: B ⊣ Δ
         --  ---------------------------
@@ -249,7 +249,7 @@ checkPattern patt t_patt = case patt of
             subtype (sub $ getDataId t_inj) t_patt
             let check p t = checkPattern p =<< apply (sub t)
             ps' <- zipWithM check ps ts
-            apply (T.PInj (coerce name) (map fst ps'), t_patt)
+            apply (T.PInj (coerce name) ps', t_patt)
           where
             substituteTVarsOf = \case
                 TAll tvar t -> do
@@ -781,7 +781,6 @@ applyBranch (T.Branch (p, t) e) = do
 applyPattern :: T.Pattern' Type -> Tc (T.Pattern' Type)
 applyPattern = \case
     T.PVar id      -> T.PVar <$> apply id
-    T.PLit (lit, t) -> T.PLit . (lit, ) <$> apply t
     T.PInj name ps -> T.PInj name <$> apply ps
     p              -> pure p
 

src/TypeChecker/TypeCheckerHm.hs

@@ -7,7 +7,7 @@
 module TypeChecker.TypeCheckerHm where
 
 import           Auxiliary                 (int, litType, maybeToRightM, unzip4)
-import Auxiliary qualified as Aux
+import qualified Auxiliary                 as Aux
 import           Control.Monad.Except
 import           Control.Monad.Identity    (Identity, runIdentity)
 import           Control.Monad.Reader
@@ -18,14 +18,14 @@ import Data.Function (on)
 import           Data.List                 (foldl', nub, sortOn)
 import           Data.List.Extra           (unsnoc)
 import           Data.Map                  (Map)
-import Data.Map qualified as M
+import qualified Data.Map                  as M
 import           Data.Maybe                (fromJust)
 import           Data.Set                  (Set)
-import Data.Set qualified as S
+import qualified Data.Set                  as S
 import           Debug.Trace               (trace)
 import           Grammar.Abs
 import           Grammar.Print             (printTree)
-import TypeChecker.TypeCheckerIr qualified as T
+import qualified TypeChecker.TypeCheckerIr as T
 
 {-
 TODO
@@ -403,22 +403,22 @@ checkCase expT brnchs = do
 
 inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type)
 inferBranch err@(Branch pat expr) = do
-    newPat@(pat, branchT) <- inferPattern pat
+    pat@(_, branchT) <- inferPattern pat
     (sub, newExp@(_, exprT)) <- catchError (withPattern pat (algoW expr)) (\x -> throwError Error{msg = x.msg <> " in pattern '" <> printTree err <> "'", catchable = False})
     return
         ( sub
         , apply sub branchT
-        , T.Branch (apply sub newPat) (apply sub newExp)
+        , T.Branch (apply sub pat) (apply sub newExp)
         , apply sub exprT
         )
 
 inferPattern :: Pattern -> Infer (T.Pattern' Type, Type)
 inferPattern = \case
-    PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt)
+    PLit lit -> let lt = litType lit in return (T.PLit lit, lt)
     PCatch -> (T.PCatch,) <$> fresh
     PVar x -> do
         fr <- fresh
-        let pvar = T.PVar (coerce x, fr)
+        let pvar = T.PVar (coerce x)
         return (pvar, fr)
     PEnum p -> do
         t <- gets (M.lookup (coerce p) . injections)
@@ -473,7 +473,7 @@ inferPattern = \case
             )
         sub <- composeAll <$> zipWithM unify vs (map snd patterns)
         return
-            ( T.PInj (coerce constr) (apply sub (map fst patterns))
+            ( T.PInj (coerce constr) (apply sub patterns)
             , apply sub ret
             )
 
@@ -718,8 +718,8 @@ instance SubstType (T.Branch' Type) where
 
 instance SubstType (T.Pattern' Type) where
     apply s = \case
-        T.PVar (iden, t) -> T.PVar (iden, apply s t)
+        T.PVar iden -> T.PVar iden
-        T.PLit (lit, t) -> T.PLit (lit, apply s t)
+        T.PLit lit  -> T.PLit lit
         T.PInj i ps -> T.PInj i $ apply s ps
         T.PCatch    -> T.PCatch
         T.PEnum i   -> T.PEnum i
@@ -761,9 +761,9 @@ withBindings xs =
     local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs})
 
 -- | Run the monadic action with a pattern
-withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a
+withPattern :: (Monad m, MonadReader Ctx m) => (T.Pattern' Type, Type) -> m a -> m a
-withPattern p ma = case p of
+withPattern (p, t) ma = case p of
-    T.PVar (x, t) -> withBinding x t ma
+    T.PVar x    -> withBinding x t ma
     T.PInj _ ps -> foldl' (flip withPattern) ma ps
     T.PLit _    -> ma
     T.PCatch    -> ma

src/TypeChecker/TypeCheckerIr.hs

@@ -153,10 +153,13 @@ instance Print t => Print [Inj' t] where
     prt i [x] = prt i x
     prt i (x : xs) = prPrec i 0 $ concatD [prt i x, doc $ showString "\n  ", prt i xs]
 
+instance Print t => Print (Pattern' t, t) where
+    prt i (p, t) = prPrec i 1 (concatD [prt i p, prt i t])
+
 instance Print t => Print (Pattern' t) where
     prt i = \case
         PVar name -> prPrec i 1 (concatD [prt 0 name])
-        PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit])
+        PLit lit -> prPrec i 1 (concatD [prt 0 lit])
         PCatch -> prPrec i 1 (concatD [doc (showString "_")])
         PEnum name -> prPrec i 1 (concatD [prt 0 name])
         PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns])